Changeset 6487 for branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS
- Timestamp:
- 2016-04-20T11:33:10+02:00 (8 years ago)
- Location:
- branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS
- Files:
-
- 45 edited
- 2 copied
Legend:
- Unmodified
- Added
- Removed
-
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/COMPILE/Fmake_config.sh
r6486 r6487 65 65 [ -f ${2}/EXP00/iodef.xml ] && \cp -R ${2}/EXP00/iodef.xml ${1}/EXP00/. 66 66 [ -f ${2}/EXP00/field_def.xml ] && \cp -R ${2}/EXP00/field_def.xml ${1}/EXP00/. 67 [ -f ${2}/EXP00/file_def.xml ] && \cp -R ${2}/EXP00/file_def.xml ${1}/EXP00/. 67 68 [ -f ${2}/EXP00/domain_def.xml ] && \cp -R ${2}/EXP00/domain_def.xml ${1}/EXP00/. 68 69 [ -f ${2}/EXP00/xmlio_server.def ] && \cp -R ${2}/EXP00/xmlio_server.def ${1}/EXP00/. -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/COMPILE/Fprep_agrif.sh
r6486 r6487 57 57 #- AGRIF conv 58 58 if [ "$AGRIFUSE" == 1 ]; then 59 #-MPI for AGRIF 60 if [ ! -f ${MAIN_DIR}/EXTERNAL/AGRIF/nemo_mpi.h ];then 61 echo '#if defined key_mpp_mpi' > ${MAIN_DIR}/EXTERNAL/AGRIF/nemo_mpi.h 62 echo '#define AGRIF_MPI' >> ${MAIN_DIR}/EXTERNAL/AGRIF/nemo_mpi.h 63 echo '#endif' >> ${MAIN_DIR}/EXTERNAL/AGRIF/nemo_mpi.h 64 fi 59 65 60 66 #- CONV 61 #fcm build ${TOOLS_DIR}/conv.cfg || exit 1 62 gmake -C ${MAIN_DIR}/EXTERNAL/AGRIF/LIB 67 fcm build ${COMPIL_DIR}/conv.cfg || exit 1 68 #C_COMPILER=${CC-cc} 69 #gmake CC=${C_COMPILER} -C ${MAIN_DIR}/EXTERNAL/AGRIF/LIB 63 70 64 71 #- AGRIF sources … … 67 74 [ ! -d $2/$1/OPAFILES/AGRIF_MODELFILES ] && mkdir $2/$1/OPAFILES/AGRIF_MODELFILES 68 75 cp -f -r ${MAIN_DIR}/EXTERNAL/AGRIF/agrif_opa.in $2/$1/OPAFILES/ 69 cp -f -r ${MAIN_DIR}/EXTERNAL/AGRIF/conv $2/$1/OPAFILES/ 76 #cp -f -r ${MAIN_DIR}/EXTERNAL/AGRIF/conv $2/$1/OPAFILES/ 77 cp -f -r $2/$1/AGRIFLIB/bin/conv $2/$1/OPAFILES/ 70 78 71 79 fi -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/COMPILE/bld.cfg
r6486 r6487 41 41 bld::tool::fppflags::nemo %FPPFLAGS -I$CONFIG_DIR/$NEW_CONF/OPAFILES/inc 42 42 bld::tool::fppflags::ioipsl %FPPFLAGS 43 bld::tool::fppflags::agrif %FPPFLAGS 43 bld::tool::fppflags::agrif %FPPFLAGS -include ${MAIN_DIR}/EXTERNAL/AGRIF/nemo_mpi.h 44 44 45 45 # Ignore the following dependencies -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/COMPILE/bld_preproagr.cfg
r6486 r6487 52 52 bld::excl_dep use::ioipsl 53 53 bld::excl_dep use::xios 54 bld::excl_dep use::agrif_grids 54 55 bld::excl_dep use::agrif_types 55 56 bld::excl_dep use::agrif_util -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/COMPILE/conv.cfg
r6486 r6487 8 8 # Build information 9 9 # ------------------------------------------------------------------------------ 10 inc $COMPIL_DIR/arch .fcm10 inc $COMPIL_DIR/arch_nemo.fcm 11 11 12 bld::tool::cc %CC 13 bld::tool::cflags %CFLAGS 12 14 bld::tool::make %MK 13 15 … … 19 21 dir::root $NEMO_TDIR/$NEW_CONF/AGRIFLIB 20 22 21 bld::tool::cflags::convsrc -O022 bld::tool::ld::convsrc cc23 bld::tool::ldflags::convsrc -O ../obj/fortran.o ../obj/fortran.o24 bld::pp 123 #bld::tool::cflags::convsrc -O0 24 #bld::tool::ld::convsrc cc 25 #bld::tool::ldflags::convsrc -O ../obj/fortran.o ../obj/fortran.o 26 #bld::pp 1 25 27 26 28 -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/COMPILE/tools.txt
r6486 r6487 1 REBUILD1 SIREN -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/NESTING/agulhas
r6486 r6487 17 17 removeclosedseas = true 18 18 type_bathy_interp = 0 19 rn_hmin = -3 19 20 / 20 21 … … 39 40 pa1 = 245.58132232490 40 41 N = 31 42 ldbletanh = .FALSE. 43 ppa2 = 0.0 44 ppkth2 = 0.0 45 ppacr2 = 0.0 41 46 / 42 47 … … 45 50 parent_bathy_meter = 'bathy_meter.nc' 46 51 parent_batmet_name = 'Bathymetry' 47 e3zps_min = 2 5.48 e3zps_rat = 0. 252 e3zps_min = 20. 53 e3zps_rat = 0.1 49 54 / 50 55 -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/NESTING/src/agrif_connect_topo.f90
r6486 r6487 105 105 IMPLICIT NONE 106 106 ! 107 REAL*8 :: za 1,za0,zsur,zacr,zkth,zmin,zmax107 REAL*8 :: za2,za1,za0,zsur,zacr,zkth,zacr2,zkth2,zmin,zmax 108 108 TYPE(Coordinates) :: Grid 109 109 INTEGER :: i,j … … 134 134 za0 = pa0 135 135 za1 = pa1 136 za2 = pa2 136 137 ! 137 138 ELSE … … 147 148 148 149 zacr = ppacr 149 zkth = ppkth 150 150 zkth = ppkth 151 zacr2 = ppacr2 152 zkth2 = ppkth2 151 153 ! 152 154 ALLOCATE(gdepw(N),gdept(N),e3w(N),e3t(N)) 153 155 ! 154 DO i = 1,N 155 gdepw(i) = (zsur+za0*i+za1*zacr*LOG(COSH((i-zkth)/zacr))) 156 gdept(i) = (zsur+za0*(i+0.5)+za1*zacr*LOG(COSH(((i+0.5)-zkth)/zacr))) 157 e3w(i) = (za0 + za1 * TANH((i-zkth)/zacr)) 158 e3t(i) = (za0 + za1 * TANH(((i+0.5)-zkth)/zacr)) 159 END DO 156 IF( ppkth == 0. ) THEN ! uniform vertical grid 157 za1 = pphmax / FLOAT(N-1) 158 DO i = 1, N 159 gdepw(i) = ( i - 1 ) * za1 160 gdept(i) = ( i - 0.5 ) * za1 161 e3w (i) = za1 162 e3t (i) = za1 163 END DO 164 ELSE ! Madec & Imbard 1996 function 165 IF( .NOT. ldbletanh ) THEN 166 DO i = 1,N 167 ! 168 gdepw(i) = (zsur+za0*i+za1*zacr*LOG(COSH((i-zkth)/zacr))) 169 gdept(i) = (zsur+za0*(i+0.5)+za1*zacr*LOG(COSH(((i+0.5)-zkth)/zacr))) 170 e3w(i) = (za0 + za1 * TANH((i-zkth)/zacr)) 171 e3t(i) = (za0 + za1 * TANH(((i+0.5)-zkth)/zacr)) 172 ! 173 END DO 174 ELSE 175 DO i = 1,N 176 ! Double tanh function 177 gdepw(i) = ( zsur + za0*i + za1 * zacr * LOG ( COSH( (i-zkth ) / zacr ) ) & 178 & + za2 * zacr2* LOG ( COSH( (i-zkth2) / zacr2 ) ) ) 179 gdept(i) = ( zsur + za0*(i+0.5) + za1 * zacr * LOG ( COSH( ((i+0.5)-zkth ) / zacr ) ) & 180 & + za2 * zacr2* LOG ( COSH( ((i+0.5)-zkth2) / zacr2 ) ) ) 181 e3w (i) = za0 + za1 * TANH( (i-zkth ) / zacr ) & 182 & + za2 * TANH( (i-zkth2) / zacr2 ) 183 e3t (i) = za0 + za1 * TANH( ((i+0.5)-zkth ) / zacr ) & 184 & + za2 * TANH( ((i+0.5)-zkth2) / zacr2 ) 185 END DO 186 ENDIF 187 ENDIF 160 188 ! 161 189 gdepw(1) = 0.0 162 190 zmax = gdepw(N) + e3t(N) 163 zmin = gdepw(4) 191 IF( rn_hmin < 0. ) THEN ; i = - INT( rn_hmin ) ! from a nb of level 192 ELSE ; i = MINLOC( gdepw, mask = gdepw > rn_hmin, dim = 1 ) ! from a depth 193 ENDIF 194 zmin = gdepw(i+1) 164 195 ! 165 196 IF ( .NOT. ASSOCIATED(Grid%bathy_level)) & … … 227 258 IMPLICIT NONE 228 259 ! 229 REAL*8 :: za 1,za0,zsur,zacr,zkth,zmin,zmax260 REAL*8 :: za2,za1,za0,zsur,zacr,zkth,zacr2,zkth2,zmin,zmax 230 261 TYPE(Coordinates) :: Grid 231 262 INTEGER :: i,j … … 257 288 za0 = pa0 258 289 za1 = pa1 290 za2 = pa2 259 291 ! 260 292 ELSE … … 264 296 WRITE(*,*) 'please check values of variables' 265 297 WRITE(*,*) 'in namelist vertical_grid section' 266 WRITE(*,*) ' ' 267 STOP 298 WRITE(*,*) ' ' 299 STOP 268 300 ! 269 301 ENDIF 270 ! 302 271 303 zacr = ppacr 272 zkth = ppkth 273 304 zkth = ppkth 305 zacr2 = ppacr2 306 zkth2 = ppkth2 274 307 ! 275 308 ALLOCATE(gdepw(N),gdept(N),e3w(N),e3t(N)) 276 309 ! 277 DO i = 1,N 278 ! 279 gdepw(i) = (zsur+za0*i+za1*zacr*LOG(COSH((i-zkth)/zacr))) 280 gdept(i) = (zsur+za0*(i+0.5)+za1*zacr*LOG(COSH(((i+0.5)-zkth)/zacr))) 281 e3w(i) = (za0 + za1 * TANH((i-zkth)/zacr)) 282 e3t(i) = (za0 + za1 * TANH(((i+0.5)-zkth)/zacr)) 283 END DO 310 IF( ppkth == 0. ) THEN ! uniform vertical grid 311 za1 = pphmax / FLOAT(N-1) 312 DO i = 1, N 313 gdepw(i) = ( i - 1 ) * za1 314 gdept(i) = ( i - 0.5 ) * za1 315 e3w (i) = za1 316 e3t (i) = za1 317 END DO 318 ELSE ! Madec & Imbard 1996 function 319 IF( .NOT. ldbletanh ) THEN 320 DO i = 1,N 321 ! 322 gdepw(i) = (zsur+za0*i+za1*zacr*LOG(COSH((i-zkth)/zacr))) 323 gdept(i) = (zsur+za0*(i+0.5)+za1*zacr*LOG(COSH(((i+0.5)-zkth)/zacr))) 324 e3w(i) = (za0 + za1 * TANH((i-zkth)/zacr)) 325 e3t(i) = (za0 + za1 * TANH(((i+0.5)-zkth)/zacr)) 326 ! 327 END DO 328 ELSE 329 DO i = 1,N 330 ! Double tanh function 331 gdepw(i) = ( zsur + za0*i + za1 * zacr * LOG ( COSH( (i-zkth ) / zacr ) ) & 332 & + za2 * zacr2* LOG ( COSH( (i-zkth2) / zacr2 ) ) ) 333 gdept(i) = ( zsur + za0*(i+0.5) + za1 * zacr * LOG ( COSH( ((i+0.5)-zkth ) / zacr ) ) & 334 & + za2 * zacr2* LOG ( COSH( ((i+0.5)-zkth2) / zacr2 ) ) ) 335 e3w (i) = za0 + za1 * TANH( (i-zkth ) / zacr ) & 336 & + za2 * TANH( (i-zkth2) / zacr2 ) 337 e3t (i) = za0 + za1 * TANH( ((i+0.5)-zkth ) / zacr ) & 338 & + za2 * TANH( ((i+0.5)-zkth2) / zacr2 ) 339 END DO 340 ENDIF 341 ENDIF 284 342 ! 285 343 gdepw(1) = 0.0 … … 684 742 ! for consistency with fine grid bathymetry * 685 743 ! * 686 ! if a given coarse grid point is masked and one of the 687 ! child grid points contained in this coarse cell is not masked 688 ! the corresponding coarse grid point is unmasked with gdepw(4)*689 ! value 744 ! if a given coarse grid point is masked and one of the * 745 ! child grid points contained in this coarse cell is not masked * 746 ! the corresponding coarse grid point is unmasked with rn_hmin * 747 ! value * 690 748 ! * 691 749 ! - input : * … … 704 762 ! 705 763 INTEGER :: ideb,jdeb,ifin,jfin 706 REAL*8 :: za 1,za0,zsur,zacr,zkth,zmin764 REAL*8 :: za2,za1,za0,zsur,zacr,zkth,zacr2,zkth2,zmin 707 765 INTEGER :: i,j 708 766 INTEGER :: k1 … … 727 785 za0 = pa0 728 786 za1 = pa1 787 za2 = pa2 729 788 ! 730 789 ELSE … … 740 799 741 800 zacr = ppacr 742 zkth = ppkth 743 801 zkth = ppkth 802 zacr2 = ppacr2 803 zkth2 = ppkth2 744 804 ! 745 805 ALLOCATE(gdepw(N),gdept(N),e3w(N),e3t(N)) 746 806 ! 747 DO i = 1,N 748 ! 749 gdepw(i) = (zsur+za0*i+za1*zacr*LOG(COSH((i-zkth)/zacr))) 750 gdept(i) = (zsur+za0*(i+0.5)+za1*zacr*LOG(COSH(((i+0.5)-zkth)/zacr))) 751 e3w(i) = (za0 + za1 * TANH((i-zkth)/zacr)) 752 e3t(i) = (za0 + za1 * TANH(((i+0.5)-zkth)/zacr)) 753 END DO 754 ! 755 zmin = gdepw(4) 807 IF( ppkth == 0. ) THEN ! uniform vertical grid 808 za1 = pphmax / FLOAT(N-1) 809 DO i = 1, N 810 gdepw(i) = ( i - 1 ) * za1 811 gdept(i) = ( i - 0.5 ) * za1 812 e3w (i) = za1 813 e3t (i) = za1 814 END DO 815 ELSE ! Madec & Imbard 1996 function 816 IF( .NOT. ldbletanh ) THEN 817 DO i = 1,N 818 ! 819 gdepw(i) = (zsur+za0*i+za1*zacr*LOG(COSH((i-zkth)/zacr))) 820 gdept(i) = (zsur+za0*(i+0.5)+za1*zacr*LOG(COSH(((i+0.5)-zkth)/zacr))) 821 e3w(i) = (za0 + za1 * TANH((i-zkth)/zacr)) 822 e3t(i) = (za0 + za1 * TANH(((i+0.5)-zkth)/zacr)) 823 ! 824 END DO 825 ELSE 826 DO i = 1,N 827 ! Double tanh function 828 gdepw(i) = ( zsur + za0*i + za1 * zacr * LOG ( COSH( (i-zkth ) / zacr ) ) & 829 & + za2 * zacr2* LOG ( COSH( (i-zkth2) / zacr2 ) ) ) 830 gdept(i) = ( zsur + za0*(i+0.5) + za1 * zacr * LOG ( COSH( ((i+0.5)-zkth ) / zacr ) ) & 831 & + za2 * zacr2* LOG ( COSH( ((i+0.5)-zkth2) / zacr2 ) ) ) 832 e3w (i) = za0 + za1 * TANH( (i-zkth ) / zacr ) & 833 & + za2 * TANH( (i-zkth2) / zacr2 ) 834 e3t (i) = za0 + za1 * TANH( ((i+0.5)-zkth ) / zacr ) & 835 & + za2 * TANH( ((i+0.5)-zkth2) / zacr2 ) 836 END DO 837 ENDIF 838 ENDIF 839 ! 840 IF( rn_hmin < 0. ) THEN ; i = - INT( rn_hmin ) ! from a nb of level 841 ELSE ; i = MINLOC( gdepw, mask = gdepw > rn_hmin, dim = 1 ) ! from a depth 842 ENDIF 843 zmin = gdepw(i+1) 756 844 ! 757 845 diff = 0 -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/NESTING/src/agrif_partial_steps.f90
r6486 r6487 36 36 ! 37 37 TYPE(Coordinates) :: Grid 38 REAL*8 :: za 1,za0,zsur,zacr,zkth,zdepth,zdepwp,zmin,zmax,zdiff,ze3tp,ze3wp38 REAL*8 :: za2,za1,za0,zsur,zacr,zkth,zacr2,zkth2,zdepth,zdepwp,zmin,zmax,zdiff,ze3tp,ze3wp 39 39 INTEGER :: i,j,jk,jj,ji,jpj,jpi,ik,ii,ipt,jpt 40 40 INTEGER, DIMENSION(1) :: k … … 76 76 za0 = pa0 77 77 za1 = pa1 78 za2 = pa2 78 79 ! 79 80 ELSE … … 88 89 ENDIF 89 90 90 zacr = ppacr 91 zkth = ppkth 92 ! 93 DO i = 1,N 94 ! 95 gdepw(i) = (zsur+za0*i+za1*zacr*LOG(COSH((i-zkth)/zacr))) 96 gdept(i) = (zsur+za0*(i+0.5)+za1*zacr*LOG(COSH(((i+0.5)-zkth)/zacr))) 97 e3w(i) = (za0 + za1 * TANH((i-zkth)/zacr)) 98 e3t(i) = (za0 + za1 * TANH(((i+0.5)-zkth)/zacr)) 99 ! 100 END DO 101 ! 102 91 zacr = ppacr 92 zkth = ppkth 93 zacr2 = ppacr2 94 zkth2 = ppkth2 95 ! 96 IF( ppkth == 0. ) THEN ! uniform vertical grid 97 za1 = pphmax / FLOAT(N-1) 98 DO i = 1, N 99 gdepw(i) = ( i - 1 ) * za1 100 gdept(i) = ( i - 0.5 ) * za1 101 e3w (i) = za1 102 e3t (i) = za1 103 END DO 104 ELSE ! Madec & Imbard 1996 function 105 IF( .NOT. ldbletanh ) THEN 106 DO i = 1,N 107 ! 108 gdepw(i) = (zsur+za0*i+za1*zacr*LOG(COSH((i-zkth)/zacr))) 109 gdept(i) = (zsur+za0*(i+0.5)+za1*zacr*LOG(COSH(((i+0.5)-zkth)/zacr))) 110 e3w(i) = (za0 + za1 * TANH((i-zkth)/zacr)) 111 e3t(i) = (za0 + za1 * TANH(((i+0.5)-zkth)/zacr)) 112 ! 113 END DO 114 ELSE 115 DO i = 1,N 116 ! Double tanh function 117 gdepw(i) = ( zsur + za0*i + za1 * zacr * LOG ( COSH( (i-zkth ) / zacr ) ) & 118 & + za2 * zacr2* LOG ( COSH( (i-zkth2) / zacr2 ) ) ) 119 gdept(i) = ( zsur + za0*(i+0.5) + za1 * zacr * LOG ( COSH( ((i+0.5)-zkth ) / zacr ) ) & 120 & + za2 * zacr2* LOG ( COSH( ((i+0.5)-zkth2) / zacr2 ) ) ) 121 e3w (i) = za0 + za1 * TANH( (i-zkth ) / zacr ) & 122 & + za2 * TANH( (i-zkth2) / zacr2 ) 123 e3t (i) = za0 + za1 * TANH( ((i+0.5)-zkth ) / zacr ) & 124 & + za2 * TANH( ((i+0.5)-zkth2) / zacr2 ) 125 END DO 126 ENDIF 127 ENDIF 103 128 gdepw(1) = 0.0 104 129 ! … … 106 131 ! 107 132 zmax = gdepw(N) + e3t(N) 108 zmin = gdepw(4) 133 IF( rn_hmin < 0. ) THEN ; i = - INT( rn_hmin ) ! from a nb of level 134 ELSE ; i = MINLOC( gdepw, mask = gdepw > rn_hmin, dim = 1 ) ! from a depth 135 ENDIF 136 zmin = gdepw(i+1) 109 137 ! 110 138 ! Initialize bathy_level to the maximum ocean level available … … 235 263 INTEGER :: i,j,ji,ij,ii,jj,jpt,ipt 236 264 REAL,DIMENSION(N) :: gdepw,e3t 237 REAL :: za0,za1,z sur,zacr,zkth,zmin,zmax,zdepth265 REAL :: za0,za1,za2,zsur,zacr,zacr2,zkth,zkth2,zmin,zmax,zdepth 238 266 INTEGER :: kbathy,jk,diff 239 267 INTEGER :: bornex,borney,bornex2,borney2 240 ! 268 ! 241 269 IF ( ( pa0 == 0 .OR. pa1 == 0 .OR. psur == 0 ) & 242 270 .AND. ppdzmin.NE.0 .AND. pphmax.NE.0 ) THEN 243 271 ! 272 WRITE(*,*) 'psur,pa0,pa1 computed' 244 273 za1=( ppdzmin - pphmax / (N-1) ) & 245 274 / ( TANH((1-ppkth)/ppacr) - ppacr/(N-1) & … … 253 282 pa0.NE.0 .AND. pa1.NE.0 ) THEN 254 283 ! 284 WRITE(*,*) 'psur,pa0,pa1 given by namelist' 255 285 zsur = psur 256 286 za0 = pa0 257 287 za1 = pa1 288 za2 = pa2 258 289 ! 259 290 ELSE … … 263 294 WRITE(*,*) 'please check values of variables' 264 295 WRITE(*,*) 'in namelist vertical_grid section' 265 WRITE(*,*) ' ' 266 ! 267 ENDIF 268 ! 269 zacr = ppacr 270 zkth = ppkth 271 ! 272 DO i = 1,N 273 ! 274 gdepw(i) = (zsur+za0*i+za1*zacr*LOG(COSH((i-zkth)/zacr))) 275 e3t(i) = (za0 + za1 * TANH(((i+0.5)-zkth)/zacr)) 276 END DO 277 ! 296 WRITE(*,*) ' ' 297 STOP 298 ! 299 ENDIF 300 301 zacr = ppacr 302 zkth = ppkth 303 zacr2 = ppacr2 304 zkth2 = ppkth2 305 ! 306 IF( ppkth == 0. ) THEN ! uniform vertical grid 307 za1 = pphmax / FLOAT(N-1) 308 DO i = 1, N 309 gdepw(i) = ( i - 1 ) * za1 310 e3t (i) = za1 311 END DO 312 ELSE ! Madec & Imbard 1996 function 313 IF( .NOT. ldbletanh ) THEN 314 DO i = 1,N 315 ! 316 gdepw(i) = (zsur+za0*i+za1*zacr*LOG(COSH((i-zkth)/zacr))) 317 e3t(i) = (za0 + za1 * TANH(((i+0.5)-zkth)/zacr)) 318 ! 319 END DO 320 ELSE 321 DO i = 1,N 322 ! Double tanh function 323 gdepw(i) = ( zsur + za0*i + za1 * zacr * LOG ( COSH( (i-zkth ) / zacr ) ) & 324 & + za2 * zacr2* LOG ( COSH( (i-zkth2) / zacr2 ) ) ) 325 e3t (i) = za0 + za1 * TANH( ((i+0.5)-zkth ) / zacr ) & 326 & + za2 * TANH( ((i+0.5)-zkth2) / zacr2 ) 327 END DO 328 ENDIF 329 ENDIF 278 330 gdepw(1) = 0.0 279 !280 331 ! 281 332 diff = 0 … … 344 395 ! 345 396 zmax = gdepw(N) + e3t(N) 346 zmin = gdepw(4) 397 IF( rn_hmin < 0. ) THEN ; i = - INT( rn_hmin ) ! from a nb of level 398 ELSE ; i = MINLOC( gdepw, mask = gdepw > rn_hmin, dim = 1 ) ! from a depth 399 ENDIF 400 zmin = gdepw(i+1) 347 401 ! 348 402 ! check that interpolated value stays at the same level … … 646 700 REAL*8, DIMENSION(:,:,:) :: fse3u,fse3t,fse3v 647 701 ! 648 REAL*8 :: za 1,za0,zsur,zacr,zkth,zdepth,zdepwp,zmin,zmax,zdiff,ze3tp,ze3wp702 REAL*8 :: za2,za1,za0,zsur,zacr,zkth,zacr2,zkth2,zdepth,zdepwp,zmin,zmax,zdiff,ze3tp,ze3wp 649 703 INTEGER :: i,j,jk,jj,ji,jpj,jpi,ik,ii,ipt,jpt,jpk 650 704 INTEGER, DIMENSION(1) :: k … … 660 714 ALLOCATE(gdepw(jpk),e3t(jpk)) 661 715 ALLOCATE(gdepw_ps(jpi,jpj,jpk)) 662 ! 716 ! 663 717 IF ( ( pa0 == 0 .OR. pa1 == 0 .OR. psur == 0 ) & 664 718 .AND. ppdzmin.NE.0 .AND. pphmax.NE.0 ) THEN … … 668 722 / ( TANH((1-ppkth)/ppacr) - ppacr/(jpk-1) & 669 723 * ( LOG( COSH( (jpk - ppkth) / ppacr) ) & 670 - LOG( COSH( ( 1 - ppkth) / ppacr) ) ) ) 671 ! 724 - LOG( COSH( ( 1 - ppkth) / ppacr) ) ) ) 725 672 726 za0 = ppdzmin - za1 * TANH( (1-ppkth) / ppacr ) 673 727 zsur = - za0 - za1 * ppacr * LOG( COSH( (1-ppkth) / ppacr ) ) … … 676 730 pa0.NE.0 .AND. pa1.NE.0 ) THEN 677 731 ! 732 WRITE(*,*) 'psur,pa0,pa1 given by namelist' 678 733 zsur = psur 679 734 za0 = pa0 680 za1 = pa1 681 ! 682 ENDIF 683 684 zacr = ppacr 685 zkth = ppkth 735 za1 = pa1 736 za2 = pa2 737 ! 738 ELSE 739 ! 740 WRITE(*,*) 'ERROR ***** bad vertical grid parameters ...' 741 WRITE(*,*) ' ' 742 WRITE(*,*) 'please check values of variables' 743 WRITE(*,*) 'in namelist vertical_grid section' 744 WRITE(*,*) ' ' 745 STOP 746 ! 747 ENDIF 748 749 zacr = ppacr 750 zkth = ppkth 751 zacr2 = ppacr2 752 zkth2 = ppkth2 753 ! 754 IF( ppkth == 0. ) THEN ! uniform vertical grid 755 za1 = pphmax / FLOAT(jpk-1) 756 DO i = 1, jpk 757 gdepw(i) = ( i - 1 ) * za1 758 e3t (i) = za1 759 END DO 760 ELSE ! Madec & Imbard 1996 function 761 IF( .NOT. ldbletanh ) THEN 762 DO i = 1,jpk 763 ! 764 gdepw(i) = (zsur+za0*i+za1*zacr*LOG(COSH((i-zkth)/zacr))) 765 e3t(i) = (za0 + za1 * TANH(((i+0.5)-zkth)/zacr)) 766 ! 767 END DO 768 ELSE 769 DO i = 1,jpk 770 ! Double tanh function 771 gdepw(i) = ( zsur + za0*i + za1 * zacr * LOG ( COSH( (i-zkth ) / zacr ) ) & 772 & + za2 * zacr2* LOG ( COSH( (i-zkth2) / zacr2 ) ) ) 773 e3t (i) = za0 + za1 * TANH( ((i+0.5)-zkth ) / zacr ) & 774 & + za2 * TANH( ((i+0.5)-zkth2) / zacr2 ) 775 END DO 776 ENDIF 777 ENDIF 686 778 ! 687 779 ! 688 780 DO i = 1,jpk 689 !690 gdepw(i) = (zsur+za0*i+za1*zacr*LOG(COSH((i-zkth)/zacr)))691 e3t(i) = (za0 + za1 * TANH(((i+0.5)-zkth)/zacr))692 781 ! 693 782 fse3t(:,:,i) = e3t(i) … … 700 789 ! 701 790 zmax = gdepw(jpk) + e3t(jpk) 702 zmin = gdepw(4) 791 IF( rn_hmin < 0. ) THEN ; i = - INT( rn_hmin ) ! from a nb of level 792 ELSE ; i = MINLOC( gdepw, mask = gdepw > rn_hmin, dim = 1 ) ! from a depth 793 ENDIF 794 zmin = gdepw(i+1) 703 795 ! 704 796 DO jj = 1, jpj -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/NESTING/src/agrif_types.f90
r6486 r6487 51 51 INTEGER jpizoom,jpjzoom,nb_connection_pts 52 52 ! 53 REAL*8 ppacr,ppdzmin,pphmax,ppkth,smoothing_factor,e3zps_min,e3zps_rat 54 REAL*8 psur,pa0,pa1,adatrj 53 REAL*8 rn_hmin 54 REAL*8 ppkth2, ppacr2, ppkth,ppacr,ppdzmin,pphmax,smoothing_factor,e3zps_min,e3zps_rat 55 REAL*8 psur,pa0,pa1,pa2,adatrj 55 56 ! 57 LOGICAL ldbletanh 56 58 LOGICAL partial_steps,smoothing,bathy_update 57 59 LOGICAL new_topo,removeclosedseas,dimg,iom_activated … … 70 72 ! 71 73 NAMELIST /bathymetry/new_topo,elevation_database,elevation_name,smoothing,smoothing_factor, & 72 nb_connection_pts,removeclosedseas,type_bathy_interp 74 nb_connection_pts,removeclosedseas,type_bathy_interp,rn_hmin 73 75 ! 74 76 NAMELIST /nesting/imin,imax,jmin,jmax,rho,rhot,bathy_update,updated_parent_file 75 77 ! 76 NAMELIST /vertical_grid/ppkth,ppacr,ppdzmin,pphmax,psur,pa0,pa1,N 78 NAMELIST /vertical_grid/ppkth,ppacr,ppdzmin,pphmax,psur,pa0,pa1,N,ldbletanh,ppa2,ppkth2,ppacr2 77 79 ! 78 80 NAMELIST /partial_cells/partial_steps,parent_bathy_meter,parent_batmet_name,e3zps_min,e3zps_rat -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/cfg/variable.cfg
r5037 r6487 1 # name | units | axis | point | standard name | long name | interpolation 2 X | 1 | X | | projection_x_coordinate | | 3 Y | 1 | Y | | projection_y_coordinate | | 4 Z | 1 | Z | | projection_z_coordinate | | 5 T | 1 | T | | projection_t_coordinate | | 6 nav_lon | degrees_east | XY | T | longitude | Longitude | cubic 7 nav_lat | degrees_north | XY | T | latitude | Latitude | cubic 8 nav_lev | model_levels | Z | T | | Model levels | cubic 9 deptht | m | Z | T | depth | Vertical T levels | 10 time_counter | | T | | time | Time axis | 11 Bathymetry | m | XY | T | bathymetry | Bathymetry | cubic 12 votemper | degree_Celsius | XYZT | T | sea_water_potential_temperature | Temperature | cubic 13 vozocrtx | m s-1 | XYZT | U | | Zonal velocity | cubic 14 vomecrty | m s-1 | XYZT | V | | Meridional velocity| cubic 15 vosaline | PSU | XYZT | T | sea_water_salinity | Salinity | cubic 16 sossheig | m | XYT | T | sea_surface_height | Sea Surface Height | cubic 17 glamt | degrees_east | XY | T | | Longitude_T | cubic 18 glamu | degrees_east | XY | U | | Longitude_U | cubic 19 glamv | degrees_east | XY | V | | Longitude_V | cubic 20 glamf | degrees_east | XY | F | | Longitude_F | cubic 21 gphit | degrees_north | XY | T | | Latitude_T | cubic 22 gphiu | degrees_north | XY | U | | Latitude_U | cubic 23 gphiv | degrees_north | XY | V | | Latitude_V | cubic 24 gphif | degrees_north | XY | F | | Latitude_F | cubic 25 e1t | m | XY | T | | | cubic/rhoi 26 e1u | m | XY | U | | | cubic/rhoi 27 e1v | m | XY | V | | | cubic/rhoi 28 e1f | m | XY | F | | | cubic/rhoi 29 e2t | m | XY | T | | | cubic/rhoj 30 e2u | m | XY | U | | | cubic/rhoj 31 e2v | m | XY | V | | | cubic/rhoj 32 e2f | m | XY | F | | | cubic/rhoj 33 tmask | | XYZ | T | | | nearest 34 umask | | XYZ | U | | | nearest 35 vmask | | XYZ | V | | | nearest 36 fmask | | XYZ | F | | | nearest 37 weight | | XY | T | | | 38 kt | | | | | | 39 ndastp | | | | | | 40 adatrj | | | | | | 41 kt | | | | | | 42 rdt | | | | | | 43 rdttra1 | | | | | | 44 utau_b | | XYT | U |surface_downward_eastward_stress | | 45 vtau_b | | XYT | V |surface_downward_northward_stress | | 46 qns_b | | XYT | T | | | 47 emp_b | | XYT | T | | | 48 sfx_b | | XYT | T | | | 49 en | | XYZT | T | | | 50 avt | | XYZT | T | | | 51 avm | | XYZT | T | | | 52 avmu | | XYZT | T | | | 53 avmv | | XYZT | T | | | 54 dissl | | XYZT | T | | | 55 sbc_hc_b | | XYT | T | | | 56 sbc_sc_b | | XYT | T | | | 57 gcx | | XYT | T | | | 58 gcxb | | XYT | T | | | 59 ub | | XYZT | U | | | 60 vb | | XYZT | V | | | 61 tb | | XYZT | T | | | 62 sb | | XYZT | T | | | 63 rotb | | XYZT | T | | | 64 hdivb | | XYZT | T | | | 65 sshb | | XYT | T | | | 66 un | | XYZT | U | | | 67 vn | | XYZT | V | | | 68 tn | | XYZT | T | | | 69 sn | | XYZT | T | | | 70 rotn | | XYZT | T | | | 71 hdivn | | XYZT | T | | | 72 sshn | | XYT | T | | | 73 rhop | | XYZT | T | | | 1 # name | units | axis | pt| interpolation | long name | standard name 2 X | 1 | X | | | | projection_x_coordinate 3 Y | 1 | Y | | | | projection_y_coordinate 4 Z | 1 | Z | | | | projection_z_coordinate 5 T | 1 | T | | | | projection_t_coordinate 6 nav_lon | degrees_east | XY | T | cubic | Longitude | longitude 7 nav_lat | degrees_north | XY | T | cubic | Latitude | latitude 8 nav_lev | model_levels | Z | T | cubic | Model levels | 9 deptht | m | Z | T | | Vertical T levels | depth 10 time_counter | | T | | | Time axis | time 11 Bathymetry | m | XY | T | cubic | Bathymetry | bathymetry 12 votemper | degree_Celsius | XYZT | T | cubic | Temperature | sea_water_potential_temperature 13 vozocrtx | m s-1 | XYZT | U | cubic | Zonal velocity | 14 vomecrty | m s-1 | XYZT | V | cubic | Meridional velocity | 15 vosaline | PSU | XYZT | T | cubic | Salinity | sea_water_salinity 16 sossheig | m | XYT | T | cubic | Sea Surface Height | sea_surface_height 17 sotemper | m | XYT | T | cubic | | 18 sossheig | m | XYT | T | cubic | | 19 glamt | degrees_east | XY | T | cubic | Longitude_T | 20 glamu | degrees_east | XY | U | cubic | Longitude_U | 21 glamv | degrees_east | XY | V | cubic | Longitude_V | 22 glamf | degrees_east | XY | F | cubic | Longitude_F | 23 gphit | degrees_north | XY | T | cubic | Latitude_T | 24 gphiu | degrees_north | XY | U | cubic | Latitude_U | 25 gphiv | degrees_north | XY | V | cubic | Latitude_V | 26 gphif | degrees_north | XY | F | cubic | Latitude_F | 27 e1t | m | XY | T | cubic/rhoi | | 28 e1u | m | XY | U | cubic/rhoi | | 29 e1v | m | XY | V | cubic/rhoi | | 30 e1f | m | XY | F | cubic/rhoi | | 31 e2t | m | XY | T | cubic/rhoj | | 32 e2u | m | XY | U | cubic/rhoj | | 33 e2v | m | XY | V | cubic/rhoj | | 34 e2f | m | XY | F | cubic/rhoj | | 35 tmask | | XYZ | T | nearest | | 36 umask | | XYZ | U | nearest | | 37 vmask | | XYZ | V | nearest | | 38 fmask | | XYZ | F | nearest | | 39 weight | | XY | T | | | 40 kt | | | | | | 41 ndastp | | | | | | 42 adatrj | | | | | | 43 kt | | | | | | 44 rdt | | | | | | 45 rdttra1 | | | | | | 46 utau_b | | XY | U | | |surface_downward_eastward_stress 47 vtau_b | | XY | V | | |surface_downward_northward_stress 48 qns_b | | XY | T | | | 49 emp_b | | XY | T | | | 50 sfx_b | | XY | T | | | 51 en | | XYZ | T | | | 52 avt | | XYZ | T | | vertical eddy diffusivity | 53 avm | | XYZ | T | | vertical eddy viscosity | 54 avmu | | XYZ | T | | | 55 avmv | | XYZ | T | | | 56 dissl | | XYZ | T | | | 57 sbc_hc_b | | XY | T | | | 58 sbc_sc_b | | XY | T | | | 59 gcx | | XY | T | | | 60 gcxb | | XY | T | | | 61 ub | | XYZ | U | | | 62 vb | | XYZ | V | | | 63 tb | | XYZ | T | | | 64 sb | | XYZ | T | | | 65 rotb | | XYZ | T | | | 66 hdivb | | XYZ | T | | | 67 sshb | | XY | T | | | 68 un | | XYZ | U | | | 69 vn | | XYZ | V | | | 70 tn | | XYZ | T | | | 71 sn | | XYZ | T | | | 72 rotn | | XYZ | T | | | 73 hdivn | | XYZ | T | | | 74 sshn | | XYT | T | | | 75 rhop | | XYZ | T | | | 76 dic | | XYZT | T | | Dissolved Inorganic Carbon | mole_concentration_of_dissolved_inorganic_caron_in_sea_water 77 alkalini | | XYZT | T | | Total Alkalinity | sea_water_alkalinity_expressed_as_mole_equivalent 78 o2 | | XYZT | T | | Dissolved Oxygen | mole_concentration_of_dissolved_molecular_oxygen_in_sea_water 79 caco3 | | XYZT | T | | Calcite | 80 po4 | | XYZT | T | | Phosphate | mole_concentration_of_phosphate_in_sea_water 81 poc | | XYZT | T | | Small Particulate Organic Carbon | 82 si | | XYZT | T | | Dissolved Silicate | mole_concentration_of_silicate_in_sea_water 83 phy | | XYZT | T | | Nanophytoplankton | 84 zoo | | XYZT | T | | Microzooplankton | mole_concentration_of_microzooplankton_expressed_as_carbon_in_sea_water 85 doc | | XYZT | T | | Dissolved Organic Carbon | 86 phy2 | | XYZT | T | | Diatoms | 87 zoo2 | | XYZT | T | | Mesozooplankton | mole_concentration_of_mesozooplankton_expressed_as_carbon_in_sea_water 88 gsi | | XYZT | T | | Sinking biogenic Silica | 89 fer | | XYZT | T | | Dissolved Iron | mole_concentration_of_dissolved_iron_in_sea_water 90 bfe | | XYZT | T | | Iron in the big particles | 91 goc | | XYZT | T | | Big Particulate Organic Carbon | 92 sfe | | XYZT | T | | Iron in the small particles | 93 dfe | | XYZT | T | | Iron content of the Diatoms | 94 dsi | | XYZT | T | | Silicon content of the Diatoms | 95 nfe | | XYZT | T | | Iron content of the Nanophytoplankton | 96 nchl | | XYZT | T | | Chlorophyll of the Nanophytoplankton | 97 dchl | | XYZT | T | | Chlorophyll of the Diatoms | 98 no3 | | XYZT | T | | Nitrate | mole_concentration_of_nitrate_in_sea_water 99 nh4 | | XYZT | T | | Ammonium | mole_concentration_of_ammonium_in_sea_water 100 ppd | | XYZT | T | | | 101 ppn | | XYZT | T | | | 102 ph | | XYZT | T | | | 103 cflx | | XYZT | T | | | 104 oflx | | XYZT | T | | | 105 kg | | XYZT | T | | | 106 dpco2 | | XYZT | T | | | 107 heup | | XYZT | T | | | 108 kz | | XYZT | T | | | 109 irondep | | XYZT | T | | | 110 kt_ice | | | | | | 111 hicif | | | | | | 112 hsnif | | | | | | 113 frld | | | | | | 114 sist | | | | | | 115 tbif1 | | | | | | 116 tbif2 | | | | | | 117 tbif3 | | | | | | 118 ui_ice | | | | | | 119 vi_ice | | | | | | 120 qstoif | | | | | | 121 fsbbq | | | | | | 122 stress1_i | | | | | | 123 stress2_i | | | | | | 124 stress12_i | | | | | | 125 sxice | | | | | | 126 syice | | | | | | 127 sxxice | | | | | | 128 syyice | | | | | | 129 sxyice | | | | | | 130 sxsn | | | | | | 131 sysn | | | | | | 132 sxxsn | | | | | | 133 syysn | | | | | | 134 sxysn | | | | | | 135 sxa | | | | | | 136 sya | | | | | | 137 sxxa | | | | | | 138 syya | | | | | | 139 sxya | | | | | | 140 sxc0 | | | | | | 141 syc0 | | | | | | 142 sxxc0 | | | | | | 143 syyc0 | | | | | | 144 sxyc0 | | | | | | 145 sxc1 | | | | | | 146 syc1 | | | | | | 147 sxxc1 | | | | | | 148 syyc1 | | | | | | 149 sxyc1 | | | | | | 150 sxc2 | | | | | | 151 syc2 | | | | | | 152 sxxc2 | | | | | | 153 syyc2 | | | | | | 154 sxyc2 | | | | | | 155 sxst | | | | | | 156 syst | | | | | | 157 sxxst | | | | | | 158 syyst | | | | | | 159 sxyst | | | | | | -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/attribute.f90
r5037 r6487 81 81 ! REVISION HISTORY: 82 82 !> @date November, 2013 - Initial Version 83 !> @date November, 2014 - Fix memory leaks bug 83 !> @date November, 2014 84 !> - Fix memory leaks bug 84 85 ! 85 86 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 130 131 INTEGER(i4) :: i_type = 0 !< attribute type 131 132 INTEGER(i4) :: i_len = 0 !< number of value store in attribute 132 CHARACTER(LEN=lc) :: c_value = "none"!< attribute value if type CHAR133 CHARACTER(LEN=lc) :: c_value = 'none' !< attribute value if type CHAR 133 134 REAL(dp), DIMENSION(:), POINTER :: d_value => NULL() !< attribute value if type SHORT,INT,FLOAT or DOUBLE 134 135 END TYPE TATT 135 136 136 137 INTERFACE att_init 137 MODULE PROCEDURE att__init_c 138 MODULE PROCEDURE att__init_c 138 139 MODULE PROCEDURE att__init_dp 139 140 MODULE PROCEDURE att__init_dp_0d … … 181 182 !> @date November, 2013 - Initial Version 182 183 !> @date November, 2014 183 !> 184 !> - use function instead of overload assignment operator 184 185 !> (to avoid memory leak) 185 186 ! … … 234 235 235 236 ! local variable 236 REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_value237 REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_value 237 238 !---------------------------------------------------------------- 238 239 … … 300 301 !> @author J.Paul 301 302 !> @date November, 2013 - Initial Version 302 !> @date September, 2014 - bug fix with use of id read from attribute structure 303 ! 303 !> @date September, 2014 304 !> - bug fix with use of id read from attribute structure 305 !> 304 306 !> @param[in] td_att array of attribute structure 305 307 !> @param[in] cd_name attribute name … … 355 357 356 358 att__init_c%c_name=TRIM(ADJUSTL(cd_name)) 357 358 359 att__init_c%i_type=NF90_CHAR 360 359 361 att__init_c%c_value=TRIM(ADJUSTL(cd_value)) 360 362 att__init_c%i_len=LEN( TRIM(ADJUSTL(cd_value)) ) … … 368 370 !> 369 371 !> @author J.Paul 370 !> @d tae November, 2013 - Initial Version372 !> @date November, 2013 - Initial Version 371 373 ! 372 374 !> @param[in] cd_name attribute name … … 1068 1070 !> @author J.Paul 1069 1071 !> @date November, 2013 - Initial Version 1070 !> @date September, 2014 - take into account type of attribute. 1072 !> @date September, 2014 1073 !> - take into account type of attribute. 1071 1074 ! 1072 1075 !> @param[in] td_att attribute structure … … 1114 1117 1115 1118 CASE(NF90_CHAR) 1119 1116 1120 cl_value=td_att%c_value 1117 1121 -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/boundary.f90
r5037 r6487 26 26 !> - ld_west is logical to force used of north boundary [optional] 27 27 !> - cd_north is string character description of north boundary [optional] 28 !> - cd_south is string character description of north boundary [optional]29 !> - cd_east is string character description of northboundary [optional]30 !> - cd_west is string character description of northboundary [optional]28 !> - cd_south is string character description of south boundary [optional] 29 !> - cd_east is string character description of east boundary [optional] 30 !> - cd_west is string character description of west boundary [optional] 31 31 !> - ld_oneseg is logical to force to use only one segment for each boundary [optional] 32 32 !> … … 36 36 !> to know if boundary is use:<br/> 37 37 !> - tl_bdy\%l_use 38 !> 39 !> to know if boundary come from namelist (cn_north,..):<br/> 40 !> - tl_bdy\%l_nam 38 41 !> 39 42 !> to get the number of segment in boundary:<br/> … … 105 108 ! REVISION HISTORY: 106 109 !> @date November, 2013 - Initial Version 107 !> @date September, 2014 - add boundary description 108 !> @date November, 2014 - Fix memory leaks bug 110 !> @date September, 2014 111 !> - add boundary description 112 !> @date November, 2014 113 !> - Fix memory leaks bug 114 !> @date February, 2015 115 !> - Do not change indices read from namelist 116 !> - Change string character format of boundary read from namelist, 117 !> see boundary__get_info 109 118 !> 110 119 !> @todo add schematic to boundary structure description … … 157 166 PRIVATE :: seg__init ! initialise segment structure 158 167 PRIVATE :: seg__clean ! clean segment structure 159 PRIVATE :: seg__clean_unit ! clean segment structure168 PRIVATE :: seg__clean_unit ! clean one segment structure 160 169 PRIVATE :: seg__clean_arr ! clean array of segment structure 161 170 PRIVATE :: seg__copy ! copy segment structure in another … … 173 182 CHARACTER(LEN=lc) :: c_card = '' !< boundary cardinal 174 183 LOGICAL :: l_use = .FALSE. !< boundary use or not 184 LOGICAL :: l_nam = .FALSE. !< boundary get from namelist 175 185 INTEGER(i4) :: i_nseg = 0 !< number of segment in boundary 176 186 TYPE(TSEG), DIMENSION(:), POINTER :: t_seg => NULL() !< array of segment structure 177 187 END TYPE TBDY 178 188 189 ! module variable 179 190 INTEGER(i4), PARAMETER :: im_width=10 180 191 … … 223 234 !> @date November, 2013 - Initial Version 224 235 !> @date November, 2014 225 !> 236 !> - use function instead of overload assignment operator 226 237 !> (to avoid memory leak) 227 238 ! … … 260 271 !> @date November, 2013 - Initial Version 261 272 !> @date November, 2014 262 !> 273 !> - use function instead of overload assignment operator 263 274 !> (to avoid memory leak) 264 275 ! … … 353 364 END SUBROUTINE boundary__clean_arr 354 365 !------------------------------------------------------------------- 355 !> @brief This function put cardinal name inside file name.366 !> @brief This function put cardinal name and date inside file name. 356 367 ! 357 368 !> @details 358 ! 369 !> Examples : 370 !> cd_file="boundary.nc" 371 !> cd_card="west" 372 !> id_seg =2 373 !> cd_date=y2015m07d16 374 !> 375 !> function return "boundary_west_2_y2015m07d16.nc" 376 !> 377 !> cd_file="boundary.nc" 378 !> cd_card="west" 379 !> 380 !> function return "boundary_west.nc" 381 !> 359 382 !> @author J.Paul 360 383 !> @date November, 2013 - Initial Version … … 385 408 CHARACTER(LEN=lc) :: cl_date 386 409 CHARACTER(LEN=lc) :: cl_name 410 411 INTEGER(i4) :: il_ind 412 INTEGER(i4) :: il_indend 413 387 414 ! loop indices 388 415 !---------------------------------------------------------------- … … 400 427 cl_suffix=fct_split(TRIM(cl_basename),2,'.') 401 428 429 ! add segment number 402 430 IF( PRESENT(id_seg) )THEN 403 cl_segnum="_"//TRIM(fct_str(id_seg)) //"_"431 cl_segnum="_"//TRIM(fct_str(id_seg)) 404 432 ELSE 405 433 cl_segnum="" 406 434 ENDIF 407 435 436 ! add date 408 437 IF( PRESENT(cd_date) )THEN 409 cl_date= TRIM(ADJUSTL(cd_date))438 cl_date="_"//TRIM(ADJUSTL(cd_date)) 410 439 ELSE 411 440 cl_date="" 412 441 ENDIF 413 442 414 cl_name=TRIM(cl_base)//"_"//TRIM(cd_card)//TRIM(cl_segnum)//& 415 & TRIM(cl_date)//"."//TRIM(cl_suffix) 443 ! special case for obcdta 444 il_ind=INDEX(cl_base,'_obcdta_') 445 IF( il_ind/=0 )THEN 446 il_ind=il_ind-1+8 447 il_indend=LEN_TRIM(cl_base) 448 449 cl_name=TRIM(cl_base(1:il_ind))//TRIM(cd_card)//& 450 & TRIM(cl_segnum)//"_"//TRIM(cl_base(il_ind+1:il_indend))//& 451 & TRIM(cl_date)//"."//TRIM(cl_suffix) 452 ELSE 453 cl_name=TRIM(cl_base)//"_"//TRIM(cd_card)//TRIM(cl_segnum)//& 454 & TRIM(cl_date)//"."//TRIM(cl_suffix) 455 ENDIF 416 456 417 457 boundary_set_filename=TRIM(cl_dirname)//"/"//TRIM(cl_name) … … 442 482 !> ex : cn_north='index1,first1,last1(width)|index2,first2,last2' 443 483 !> 444 !> @note boundaries are compute on T point. change will be done to get data445 !> on other point when need be.484 !> @note Boundaries are compute on T point, but expressed on U,V point. 485 !> change will be done to get data on other point when need be. 446 486 !> 447 487 !> @author J.Paul … … 581 621 582 622 ! get namelist information 583 tl_tmp=boundary__get_info(cl_card(jk)) 623 tl_tmp=boundary__get_info(cl_card(jk),jk) 624 625 ! get segments indices 584 626 DO ji=1,tl_tmp%i_nseg 585 627 CALL boundary__add_seg(tl_bdy(jk),tl_tmp%t_seg(ji)) 586 628 ENDDO 629 ! indices from namelist or not 630 tl_bdy(jk)%l_nam=tl_tmp%l_nam 631 587 632 CALL boundary_clean(tl_tmp) 588 633 … … 642 687 !> @return boundary structure 643 688 !------------------------------------------------------------------- 644 FUNCTION boundary__init( cd_card, ld_use, td_seg )689 FUNCTION boundary__init( cd_card, ld_use, ld_nam, td_seg ) 645 690 IMPLICIT NONE 646 691 ! Argument 647 692 CHARACTER(LEN=*), INTENT(IN) :: cd_card 648 693 LOGICAL , INTENT(IN), OPTIONAL :: ld_use 694 LOGICAL , INTENT(IN), OPTIONAL :: ld_nam 649 695 TYPE(TSEG) , INTENT(IN), OPTIONAL :: td_seg 650 696 … … 664 710 boundary__init%l_use=.TRUE. 665 711 IF( PRESENT(ld_use) ) boundary__init%l_use=ld_use 712 713 boundary__init%l_nam=.FALSE. 714 IF( PRESENT(ld_nam) ) boundary__init%l_nam=ld_nam 666 715 667 716 IF( PRESENT(td_seg) )THEN … … 778 827 !> orthogonal index, first and last indices, of each segment. 779 828 !> And also the width of all segments of this boundary. 780 !> cn_north='index1,first1 ,last1(width)|index2,first2,last2'829 !> cn_north='index1,first1:last1(width)|index2,first2:last2' 781 830 !> 782 831 !> @author J.Paul 783 832 !> @date November, 2013 - Initial Version 833 !> @date february, 2015 834 !> - do not change indices read from namelist 835 !> - change format cn_north 784 836 ! 785 837 !> @param[in] cd_card boundary description 838 !> @param[in] id_jcard boundary index 786 839 !> @return boundary structure 787 840 !------------------------------------------------------------------- 788 FUNCTION boundary__get_info(cd_card )841 FUNCTION boundary__get_info(cd_card, id_jcard) 789 842 IMPLICIT NONE 790 843 ! Argument 791 844 CHARACTER(LEN=lc), INTENT(IN) :: cd_card 845 INTEGER(i4) , INTENT(IN) :: id_jcard 792 846 793 847 ! function … … 802 856 CHARACTER(LEN=lc) :: cl_index 803 857 CHARACTER(LEN=lc) :: cl_width 858 CHARACTER(LEN=lc) :: cl_tmp 804 859 CHARACTER(LEN=lc) :: cl_first 805 860 CHARACTER(LEN=lc) :: cl_last … … 818 873 ! width should be the same for all segment of one boundary 819 874 IF( TRIM(cl_seg) /= '' )THEN 875 876 ! initialise boundary 877 ! temporaty boundary, so it doesn't matter which caridnal is used 878 boundary__get_info=boundary__init('north',ld_nam=.TRUE.) 879 820 880 il_ind1=SCAN(fct_lower(cl_seg),'(') 821 881 IF( il_ind1 /=0 )THEN … … 831 891 ENDIF 832 892 ENDIF 893 833 894 ENDIF 834 895 … … 839 900 il_ind1=SCAN(fct_lower(cl_index),'(') 840 901 IF( il_ind1 /=0 )THEN 841 il_ind2=SCAN(fct_lower(cl_index),' (')902 il_ind2=SCAN(fct_lower(cl_index),')') 842 903 IF( il_ind2 /=0 )THEN 843 904 cl_index=TRIM(cl_index(:il_ind1-1))//TRIM(cl_index(il_ind2+1:)) … … 848 909 ENDIF 849 910 850 cl_first=fct_split(cl_seg,2,',') 911 912 cl_tmp=fct_split(cl_seg,2,',') 913 914 915 cl_first=fct_split(cl_tmp,1,':') 851 916 ! remove potential width information 852 917 il_ind1=SCAN(fct_lower(cl_first),'(') 853 918 IF( il_ind1 /=0 )THEN 854 il_ind2=SCAN(fct_lower(cl_first),' (')919 il_ind2=SCAN(fct_lower(cl_first),')') 855 920 IF( il_ind2 /=0 )THEN 856 921 cl_first=TRIM(cl_first(:il_ind1-1))//TRIM(cl_first(il_ind2+1:)) … … 861 926 ENDIF 862 927 863 cl_last =fct_split(cl_ seg,3,',')928 cl_last =fct_split(cl_tmp,2,':') 864 929 ! remove potential width information 865 930 il_ind1=SCAN(fct_lower(cl_last),'(') 866 931 IF( il_ind1 /=0 )THEN 867 il_ind2=SCAN(fct_lower(cl_last),' (')932 il_ind2=SCAN(fct_lower(cl_last),')') 868 933 IF( il_ind2 /=0 )THEN 869 934 cl_last=TRIM(cl_last(:il_ind1-1))//TRIM(cl_last(il_ind2+1:)) … … 879 944 IF( TRIM(cl_first) /= '' ) READ(cl_first,*) tl_seg%i_first 880 945 IF( TRIM(cl_last) /= '' ) READ(cl_last ,*) tl_seg%i_last 946 947 ! index expressed on U,V point, move on T point. 948 SELECT CASE(id_jcard) 949 CASE(jp_north, jp_east) 950 tl_seg%i_index=tl_seg%i_index+1 951 END SELECT 881 952 882 953 IF( (tl_seg%i_first == 0 .AND. tl_seg%i_last == 0) .OR. & … … 943 1014 944 1015 DO jk=1,ip_ncard 945 IF( .NOT. td_bdy(jk)%l_use .OR. td_bdy(jk)% i_nseg > 1)THEN1016 IF( .NOT. td_bdy(jk)%l_use .OR. td_bdy(jk)%l_nam )THEN 946 1017 ! nothing to be done 947 1018 ELSE … … 1480 1551 il_max(jp_east )=td_var%t_dim(2)%i_len 1481 1552 il_max(jp_west )=td_var%t_dim(2)%i_len 1482 1553 1483 1554 il_maxindex(jp_north)=td_var%t_dim(2)%i_len-ip_ghost 1484 1555 il_maxindex(jp_south)=td_var%t_dim(2)%i_len-ip_ghost … … 1515 1586 ENDIF 1516 1587 ENDDO 1517 1588 1518 1589 CALL boundary_check_corner(td_bdy, td_var) 1519 1590 … … 1650 1721 !> @date November, 2013 - Initial Version 1651 1722 !> @date November, 2014 1652 !> 1723 !> - use function instead of overload assignment operator 1653 1724 !> (to avoid memory leak) 1654 1725 ! … … 1687 1758 !> @date November, 2013 - Initial Version 1688 1759 !> @date November, 2014 1689 !> 1760 !> - use function instead of overload assignment operator 1690 1761 !> (to avoid memory leak) 1691 1762 ! -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/create_bathy.f90
r5037 r6487 20 20 !> ./SIREN/bin/create_bathy create_bathy.nam 21 21 !> @endcode 22 !> 22 !> <br/> 23 !> \image html bathy_40.png 24 !> \image latex bathy_30.png 25 !> 26 !> @note 27 !> you could find a template of the namelist in templates directory. 28 !> 23 29 !> create_bathy.nam comprise 7 namelists:<br/> 24 30 !> - logger namelist (namlog) … … 37 43 !> - cn_logfile : log filename 38 44 !> - cn_verbosity : verbosity ('trace','debug','info', 39 !> 'warning','error','fatal' )45 !> 'warning','error','fatal','none') 40 46 !> - in_maxerror : maximum number of error allowed 41 47 !> … … 52 58 !> - cn_coord1 : coordinate file 53 59 !> - in_perio1 : periodicity index 54 !> - ln_fillclosed : fill closed sea or not 60 !> - ln_fillclosed : fill closed sea or not (default is .TRUE.) 55 61 !> 56 62 !> * _variable namelist (namvar)_:<br/> 57 63 !> - cn_varinfo : list of variable and extra information about request(s) 58 64 !> to be used.<br/> 59 !> each elements of *cn_varinfo* is a string character.<br/> 65 !> each elements of *cn_varinfo* is a string character 66 !> (separated by ',').<br/> 60 67 !> it is composed of the variable name follow by ':', 61 68 !> then request(s) to be used on this variable.<br/> 62 69 !> request could be: 63 !> - interpolation method 64 !> - extrapolation method 65 !> - filter method 66 !> - > minimum value 67 !> - < maximum value 70 !> - int = interpolation method 71 !> - ext = extrapolation method 72 !> - flt = filter method 73 !> - min = minimum value 74 !> - max = maximum value 75 !> - unt = new units 76 !> - unf = unit scale factor (linked to new units) 68 77 !> 69 78 !> requests must be separated by ';'.<br/> … … 72 81 !> informations about available method could be find in @ref interp, 73 82 !> @ref extrap and @ref filter modules.<br/> 74 !> Example: 'Bathymetry: 2*hamming(2,3); >0'83 !> Example: 'Bathymetry: flt=2*hamming(2,3); min=0' 75 84 !> @note 76 85 !> If you do not specify a method which is required, … … 90 99 !> - ',' for line 91 100 !> - '/' for row 92 !> - '\' for level<br/>93 101 !> Example:<br/> 94 102 !> 3,2,3/1,4,5 => @f$ \left( \begin{array}{ccc} … … 99 107 !> - 'Bathymetry:gridT.nc' 100 108 !> - 'Bathymetry:5000,5000,5000/5000,3000,5000/5000,5000,5000' 101 !>102 !> \image html bathy_40.png103 !> \image latex bathy_30.png104 109 !> 105 110 !> * _nesting namelist (namnst)_:<br/> … … 119 124 !> - add header for user 120 125 !> - Bug fix, compute offset depending of grid point 126 !> @date June, 2015 127 !> - extrapolate all land points. 128 !> - allow to change unit. 121 129 ! 130 !> @todo 131 !> - use create_bathy_check_depth as in create_boundary 132 !> - use create_bathy_check_time as in create_boundary 133 !> - check tl_multi is not empty 134 !> 122 135 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 123 136 !---------------------------------------------------------------------- … … 482 495 ENDIF 483 496 497 ! use additional request 484 498 DO jk=1,tl_multi%i_nvar 499 500 ! change unit and apply factor 501 CALL var_chg_unit(tl_var(jk)) 502 485 503 ! forced min and max value 486 504 CALL var_limit_value(tl_var(jk)) … … 557 575 558 576 ! add other variables 559 DO jk= 1,tl_multi%i_nvar577 DO jk=tl_multi%i_nvar,1,-1 560 578 CALL file_add_var(tl_fileout, tl_var(jk)) 561 579 CALL var_clean(tl_var(jk)) … … 623 641 !> 624 642 !> @author J.Paul 625 !> - November, 2013- Initial Version643 !> @date November, 2013 - Initial Version 626 644 !> 627 645 !> @param[in] td_var variable structure … … 759 777 !> 760 778 !> @author J.Paul 761 !> - November, 2013- Initial Version779 !> @date November, 2013 - Initial Version 762 780 !> 763 781 !> @param[in] td_var variable structure … … 878 896 !> 879 897 !> @author J.Paul 880 !> - November, 2013- Initial Version898 !> @date November, 2013 - Initial Version 881 899 !> 882 900 !> @param[in] td_var variable structure … … 897 915 IMPLICIT NONE 898 916 ! Argument 899 TYPE(TVAR) , INTENT(IN) :: td_var900 TYPE(TMPP) , INTENT(IN) :: td_mpp901 INTEGER(i4) , INTENT(IN) :: id_imin902 INTEGER(i4) , INTENT(IN) :: id_imax903 INTEGER(i4) , INTENT(IN) :: id_jmin904 INTEGER(i4) , INTENT(IN) :: id_jmax917 TYPE(TVAR) , INTENT(IN) :: td_var 918 TYPE(TMPP) , INTENT(IN) :: td_mpp 919 INTEGER(i4) , INTENT(IN) :: id_imin 920 INTEGER(i4) , INTENT(IN) :: id_imax 921 INTEGER(i4) , INTENT(IN) :: id_jmin 922 INTEGER(i4) , INTENT(IN) :: id_jmax 905 923 INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_offset 906 924 INTEGER(i4), DIMENSION(:) , INTENT(IN) :: id_rho … … 989 1007 !> 990 1008 !> @author J.Paul 991 !> - November, 2013- Initial Version1009 !> @date November, 2013 - Initial Version 992 1010 !> 993 1011 !> @param[inout] td_var variable structure … … 1073 1091 1074 1092 ! extrapolate variable 1075 CALL extrap_fill_value( td_var, id_offset=id_offset(:,:), & 1076 & id_rho=id_rho(:), & 1077 & id_iext=il_iext, id_jext=il_jext ) 1093 CALL extrap_fill_value( td_var ) 1078 1094 1079 1095 ! interpolate Bathymetry -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/create_boundary.f90
r5037 r6487 23 23 !> ./SIREN/bin/create_boundary create_boundary.nam 24 24 !> @endcode 25 !> 25 !> <br/> 26 !> \image html boundary_NEATL36_70.png 27 !> \image latex boundary_NEATL36_70.png 28 !> 29 !> @note 30 !> you could find a template of the namelist in templates directory. 31 !> 26 32 !> create_boundary.nam comprise 9 namelists:<br/> 27 33 !> - logger namelist (namlog) … … 42 48 !> - cn_logfile : log filename 43 49 !> - cn_verbosity : verbosity ('trace','debug','info', 44 !> 'warning','error','fatal' )50 !> 'warning','error','fatal','none') 45 51 !> - in_maxerror : maximum number of error allowed 46 52 !> … … 79 85 !> * _variable namelist (namvar)_:<br/> 80 86 !> - cn_varinfo : list of variable and extra information about request(s) 81 !> to be used.<br/>87 !> to be used (separated by ',').<br/> 82 88 !> each elements of *cn_varinfo* is a string character.<br/> 83 89 !> it is composed of the variable name follow by ':', 84 90 !> then request(s) to be used on this variable.<br/> 85 91 !> request could be: 86 !> - interpolation method 87 !> - extrapolation method 88 !> - filter method 92 !> - int = interpolation method 93 !> - ext = extrapolation method 94 !> - flt = filter method 95 !> - unt = new units 96 !> - unf = unit scale factor (linked to new units) 89 97 !> 90 98 !> requests must be separated by ';'.<br/> … … 94 102 !> @ref extrap and @ref filter.<br/> 95 103 !> 96 !> Example: 'votemper: linear;hann;dist_weight', 'vosaline:cubic'104 !> Example: 'votemper:int=linear;flt=hann;ext=dist_weight', 'vosaline:int=cubic' 97 105 !> @note 98 106 !> If you do not specify a method which is required, … … 136 144 !> segments are separated by '|'.<br/> 137 145 !> each segments of the boundary is composed of: 138 !> - orthogonal indice (.ie. for north boundary,139 !> J-indice where boundary are).140 !> - first indice of boundary(I-indice for north boundary)141 !> - last indice of boundary(I-indice for north boundary)<br/>142 !> indices must be separated by ' ,' .<br/>146 !> - indice of velocity (orthogonal to boundary .ie. 147 !> for north boundary, J-indice). 148 !> - indice of segemnt start (I-indice for north boundary) 149 !> - indice of segment end (I-indice for north boundary)<br/> 150 !> indices must be separated by ':' .<br/> 143 151 !> - optionally, boundary size could be added between '(' and ')' 144 152 !> in the first segment defined. … … 147 155 !> 148 156 !> Examples: 149 !> - cn_north='index1,first1,last1(width)' 150 !> - cn_north='index1(width),first1,last1|index2,first2,last2' 151 !> 152 !> \image html boundary_50.png 153 !> \image latex boundary_50.png 154 !> 157 !> - cn_north='index1,first1:last1(width)' 158 !> - cn_north='index1(width),first1:last1|index2,first2:last2' 159 !> \image html boundary_50.png 160 !> \image latex boundary_50.png 155 161 !> - cn_south : south boundary indices on fine grid 156 162 !> - cn_east : east boundary indices on fine grid 157 163 !> - cn_west : west boundary indices on fine grid 158 164 !> - ln_oneseg : use only one segment for each boundary or not 159 !> - in_extrap : number of mask point to be extrapolated 160 !> 161 !> * _output namelist (namout)_:<br/> 165 !> 166 !> * _output namelist (namout)_:<br/> 162 167 !> - cn_fileout : fine grid boundary basename 163 168 !> (cardinal and segment number will be automatically added) 169 !> - dn_dayofs : date offset in day (change only ouput file name) 170 !> - ln_extrap : extrapolate land point or not 171 !> 172 !> Examples: 173 !> - cn_fileout=boundary.nc<br/> 174 !> if time_counter (16/07/2015 00h) is read on input file (see varfile), 175 !> west boundary will be named boundary_west_y2015m07d16 176 !> - dn_dayofs=-2.<br/> 177 !> if you use day offset you get boundary_west_y2015m07d14 178 !> 164 179 !> 165 180 !> @author J.Paul … … 169 184 !> - add header for user 170 185 !> - take into account grid point to compue boundaries 171 !> - reorder output dimension for north and south boundaries 186 !> - reorder output dimension for north and south boundaries 187 !> @date June, 2015 188 !> - extrapolate all land points, and add ln_extrap in namelist. 189 !> - allow to change unit. 190 !> @date July, 2015 191 !> - add namelist parameter to shift date of output file name. 172 192 !> 173 193 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 191 211 USE dom ! domain manager 192 212 USE grid ! grid manager 193 USE vgrid ! v artical grid manager213 USE vgrid ! vertical grid manager 194 214 USE extrap ! extrapolation manager 195 215 USE interp ! interpolation manager … … 213 233 INTEGER(i4) :: il_status 214 234 INTEGER(i4) :: il_fileid 215 INTEGER(i4) :: il_dim216 235 INTEGER(i4) :: il_imin0 217 236 INTEGER(i4) :: il_imax0 … … 239 258 240 259 TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim 260 261 TYPE(TDATE) :: tl_date 241 262 242 263 TYPE(TBDY) , DIMENSION(ip_ncard) :: tl_bdy … … 265 286 ! namelist variable 266 287 ! namlog 267 CHARACTER(LEN=lc) 268 CHARACTER(LEN=lc) 269 INTEGER(i4) 288 CHARACTER(LEN=lc) :: cn_logfile = 'create_boundary.log' 289 CHARACTER(LEN=lc) :: cn_verbosity = 'warning' 290 INTEGER(i4) :: in_maxerror = 5 270 291 271 292 ! namcfg 272 CHARACTER(LEN=lc) 293 CHARACTER(LEN=lc) :: cn_varcfg = 'variable.cfg' 273 294 274 295 ! namcrs 275 CHARACTER(LEN=lc) 276 INTEGER(i4) 296 CHARACTER(LEN=lc) :: cn_coord0 = '' 297 INTEGER(i4) :: in_perio0 = -1 277 298 278 299 ! namfin 279 CHARACTER(LEN=lc) 280 CHARACTER(LEN=lc) 281 INTEGER(i4) 300 CHARACTER(LEN=lc) :: cn_coord1 = '' 301 CHARACTER(LEN=lc) :: cn_bathy1 = '' 302 INTEGER(i4) :: in_perio1 = -1 282 303 283 304 !namzgr 284 INTEGER(i4) :: in_nlevel = 75 305 REAL(dp) :: dn_pp_to_be_computed = 0._dp 306 REAL(dp) :: dn_ppsur = -3958.951371276829_dp 307 REAL(dp) :: dn_ppa0 = 103.9530096000000_dp 308 REAL(dp) :: dn_ppa1 = 2.4159512690000_dp 309 REAL(dp) :: dn_ppa2 = 100.7609285000000_dp 310 REAL(dp) :: dn_ppkth = 15.3510137000000_dp 311 REAL(dp) :: dn_ppkth2 = 48.0298937200000_dp 312 REAL(dp) :: dn_ppacr = 7.0000000000000_dp 313 REAL(dp) :: dn_ppacr2 = 13.000000000000_dp 314 REAL(dp) :: dn_ppdzmin = 6._dp 315 REAL(dp) :: dn_pphmax = 5750._dp 316 INTEGER(i4) :: in_nlevel = 75 317 318 !namzps 319 REAL(dp) :: dn_e3zps_min = 25._dp 320 REAL(dp) :: dn_e3zps_rat = 0.2_dp 285 321 286 322 ! namvar … … 289 325 290 326 ! namnst 291 INTEGER(i4) 292 INTEGER(i4) 327 INTEGER(i4) :: in_rhoi = 0 328 INTEGER(i4) :: in_rhoj = 0 293 329 294 330 ! nambdy 295 LOGICAL :: ln_north = .TRUE. 296 LOGICAL :: ln_south = .TRUE. 297 LOGICAL :: ln_east = .TRUE. 298 LOGICAL :: ln_west = .TRUE. 299 CHARACTER(LEN=lc) :: cn_north = '' 300 CHARACTER(LEN=lc) :: cn_south = '' 301 CHARACTER(LEN=lc) :: cn_east = '' 302 CHARACTER(LEN=lc) :: cn_west = '' 303 LOGICAL :: ln_oneseg = .TRUE. 304 INTEGER(i4) :: in_extrap = 0 331 LOGICAL :: ln_north = .TRUE. 332 LOGICAL :: ln_south = .TRUE. 333 LOGICAL :: ln_east = .TRUE. 334 LOGICAL :: ln_west = .TRUE. 335 CHARACTER(LEN=lc) :: cn_north = '' 336 CHARACTER(LEN=lc) :: cn_south = '' 337 CHARACTER(LEN=lc) :: cn_east = '' 338 CHARACTER(LEN=lc) :: cn_west = '' 339 LOGICAL :: ln_oneseg = .TRUE. 305 340 306 341 ! namout 307 CHARACTER(LEN=lc) :: cn_fileout = 'boundary.nc' 342 CHARACTER(LEN=lc) :: cn_fileout = 'boundary.nc' 343 REAL(dp) :: dn_dayofs = 0._dp 344 LOGICAL :: ln_extrap = .FALSE. 308 345 !------------------------------------------------------------------- 309 346 … … 319 356 & cn_coord0, & !< coordinate file 320 357 & in_perio0 !< periodicity index 321 358 322 359 NAMELIST /namfin/ & !< fine grid namelist 323 360 & cn_coord1, & !< coordinate file … … 326 363 327 364 NAMELIST /namzgr/ & 328 & in_nlevel 365 & dn_pp_to_be_computed, & 366 & dn_ppsur, & 367 & dn_ppa0, & 368 & dn_ppa1, & 369 & dn_ppa2, & 370 & dn_ppkth, & 371 & dn_ppkth2, & 372 & dn_ppacr, & 373 & dn_ppacr2, & 374 & dn_ppdzmin, & 375 & dn_pphmax, & 376 & in_nlevel !< number of vertical level 377 378 NAMELIST /namzps/ & 379 & dn_e3zps_min, & 380 & dn_e3zps_rat 329 381 330 382 NAMELIST /namvar/ & !< variable namelist 331 383 & cn_varinfo, & !< list of variable and method to apply on. (ex: 'votemper:linear','vosaline:cubic' ) 332 384 & cn_varfile !< list of variable and file where find it. (ex: 'votemper:GLORYS_gridT.nc' ) 333 385 334 386 NAMELIST /namnst/ & !< nesting namelist 335 387 & in_rhoi, & !< refinement factor in i-direction … … 345 397 & cn_east , & !< east boundary indices on fine grid 346 398 & cn_west , & !< west boundary indices on fine grid 347 & ln_oneseg, & !< use only one segment for each boundary or not 348 & in_extrap !< number of mask point to be extrapolated 399 & ln_oneseg !< use only one segment for each boundary or not 349 400 350 401 NAMELIST /namout/ & !< output namelist 351 & cn_fileout !< fine grid boundary file basename 402 & cn_fileout, & !< fine grid boundary file basename 403 & dn_dayofs, & !< date offset in day (change only ouput file name) 404 & ln_extrap !< extrapolate or not 352 405 !------------------------------------------------------------------- 353 406 … … 448 501 ! check 449 502 ! check output file do not already exist 503 ! WARNING: do not work when use time to create output file name 450 504 DO jk=1,ip_ncard 451 505 cl_bdyout=boundary_set_filename( TRIM(cn_fileout), & 452 506 & TRIM(cp_card(jk)), 1 ) 507 INQUIRE(FILE=TRIM(cl_bdyout), EXIST=ll_exist) 508 IF( ll_exist )THEN 509 CALL logger_fatal("CREATE BOUNDARY: output file "//TRIM(cl_bdyout)//& 510 & " already exist.") 511 ENDIF 512 513 cl_bdyout=boundary_set_filename( TRIM(cn_fileout), & 514 & TRIM(cp_card(jk)) ) 453 515 INQUIRE(FILE=TRIM(cl_bdyout), EXIST=ll_exist) 454 516 IF( ll_exist )THEN … … 490 552 491 553 CALL iom_mpp_open(tl_bathy1) 492 554 493 555 tl_var1=iom_mpp_read_var(tl_bathy1,'Bathymetry') 494 556 495 557 CALL iom_mpp_close(tl_bathy1) 496 558 559 ! get boundaries indices 497 560 tl_bdy(:)=boundary_init(tl_var1, ln_north, ln_south, ln_east, ln_west, & 498 561 & cn_north, cn_south, cn_east, cn_west, & … … 505 568 tl_level(:)=vgrid_get_level(tl_bathy1, cl_namelist ) 506 569 507 ! get coordinate oneach segment of each boundary570 ! get coordinate for each segment of each boundary 508 571 ALLOCATE( tl_segdom1(ip_npoint,ip_maxseg,ip_ncard) ) 509 572 ALLOCATE( tl_seglvl1(ip_npoint,ip_maxseg,ip_ncard) ) 510 573 511 574 DO jl=1,ip_ncard 512 575 IF( tl_bdy(jl)%l_use )THEN … … 516 579 tl_segdom1(:,jk,jl)=create_boundary_get_dom( tl_bathy1, & 517 580 & tl_bdy(jl), jk ) 581 582 IF( .NOT. ln_extrap )THEN 583 ! get fine grid level 584 tl_seglvl1(:,jk,jl)= & 585 & create_boundary_get_level( tl_level(:), & 586 & tl_segdom1(:,jk,jl)) 587 ENDIF 518 588 519 589 ! add extra band to fine grid domain (if possible) … … 523 593 & il_rho(jp_I), il_rho(jp_J)) 524 594 ENDDO 525 526 ! get fine grid level527 tl_seglvl1(:,jk,jl)=create_boundary_get_level( tl_level(:), &528 tl_segdom1(:,jk,jl))529 595 530 596 ENDDO … … 594 660 & in_nlevel ) 595 661 596 ! use mask597 CALL create_boundary_use_mask( tl_segvar1(jvar,jk,jl), &598 & tl_seglvl1(jpoint,jk,jl))599 600 662 !del extra 601 663 CALL dom_del_extra( tl_segvar1(jvar,jk,jl), & … … 654 716 IF( tl_bdy(jl)%l_use )THEN 655 717 656 WRITE(*,'(2x,a,a)') 'work on '//TRIM(tl_bdy(jl)%c_card)//' boundary' 718 WRITE(*,'(2x,a,a)') 'work on '//TRIM(tl_bdy(jl)%c_card)//& 719 & ' boundary' 657 720 DO jk=1,tl_bdy(jl)%i_nseg 658 721 ! compute domain on fine grid … … 662 725 663 726 cl_name=tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name 664 WRITE(*,'(4x,a,a)') "work on variable "//TRIM(cl_name) 727 WRITE(*,'(4x,a,a)') "work on (extract) variable "//& 728 & TRIM(cl_name) 665 729 666 730 cl_point=tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_point … … 678 742 679 743 tl_dom1=dom_copy(tl_segdom1(jpoint,jk,jl)) 680 tl_lvl1=var_copy(tl_seglvl1(jpoint,jk,jl))681 744 682 745 ! open mpp files … … 687 750 & tl_mpp, TRIM(cl_name), tl_dom1) 688 751 689 ! use mask690 CALL create_boundary_use_mask( &691 & tl_segvar1(jvar+jj,jk,jl), tl_lvl1)692 693 752 ! del extra point 694 753 CALL dom_del_extra( tl_segvar1(jvar+jj,jk,jl), & … … 699 758 700 759 ! add attribute to variable 701 tl_att=att_init('src_file',TRIM(fct_basename(tl_mpp%c_name))) 760 tl_att=att_init('src_file', & 761 & TRIM(fct_basename(tl_mpp%c_name))) 702 762 CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), tl_att) 703 763 704 tl_att=att_init('src_i_indices',(/tl_dom1%i_imin, tl_dom1%i_imax/)) 764 tl_att=att_init('src_i_indices', & 765 & (/tl_dom1%i_imin, tl_dom1%i_imax/)) 705 766 CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), tl_att) 706 767 707 tl_att=att_init('src_j_indices',(/tl_dom1%i_jmin, tl_dom1%i_jmax/)) 768 tl_att=att_init('src_j_indices', & 769 & (/tl_dom1%i_jmin, tl_dom1%i_jmax/)) 708 770 CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), tl_att) 709 771 … … 736 798 IF( tl_bdy(jl)%l_use )THEN 737 799 738 WRITE(*,'(2x,a,a)') 'work on '//TRIM(tl_bdy(jl)%c_card)//' boundary' 800 WRITE(*,'(2x,a,a)') 'work on '//TRIM(tl_bdy(jl)%c_card)//& 801 & ' boundary' 739 802 DO jk=1,tl_bdy(jl)%i_nseg 740 803 741 804 ! for each variable of this file 742 805 DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar 743 744 WRITE(*,'(4x,a,a)') "work on variable "//&806 807 WRITE(*,'(4x,a,a)') "work on (interp) variable "//& 745 808 & TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name) 746 809 … … 759 822 760 823 tl_dom1=dom_copy(tl_segdom1(jpoint,jk,jl)) 761 tl_lvl1=var_copy(tl_seglvl1(jpoint,jk,jl))762 824 763 825 CALL create_boundary_get_coord( tl_coord1, tl_dom1, & … … 795 857 & il_jmin0, il_jmax0 ) 796 858 797 ! add extra band (if possible) to compute interpolation 859 ! add extra band (if possible) to compute 860 ! interpolation 798 861 CALL dom_add_extra(tl_dom0) 799 862 … … 815 878 CALL dom_del_extra( tl_segvar1(jvar+jj,jk,jl), & 816 879 & tl_dom0, il_rho(:) ) 817 818 ! use mask819 CALL create_boundary_use_mask( &820 & tl_segvar1(jvar+jj,jk,jl), tl_lvl1)821 880 822 881 ! del extra point on fine grid … … 889 948 890 949 IF( jvar /= tl_multi%i_nvar )THEN 891 CALL logger_error("CREATE BOUNDARY: it seems some variable can not be read") 950 CALL logger_error("CREATE BOUNDARY: it seems some variable "//& 951 & "can not be read") 892 952 ENDIF 893 894 CALL var_clean(tl_seglvl1(:,:,:))895 DEALLOCATE( tl_seglvl1 )896 953 897 954 ! write file for each segment of each boundary 898 955 DO jl=1,ip_ncard 899 956 IF( tl_bdy(jl)%l_use )THEN 900 901 SELECT CASE(TRIM(tl_bdy(jk)%c_card))902 CASE('north','south')903 il_dim=1904 CASE('east','west')905 il_dim=2906 END SELECT907 957 908 958 DO jk=1,tl_bdy(jl)%i_nseg … … 911 961 & 'T', tl_lon1, tl_lat1 ) 912 962 963 ! force to use nav_lon, nav_lat as variable name 964 tl_lon1%c_name='nav_lon' 965 tl_lat1%c_name='nav_lat' 966 913 967 ! del extra point on fine grid 914 968 CALL dom_del_extra( tl_lon1, tl_segdom1(jp_T,jk,jl) ) … … 924 978 CALL boundary_swap(tl_lat1, tl_bdy(jl)) 925 979 DO jvar=1,tl_multi%i_nvar 926 CALL boundary_swap(tl_segvar1(jvar,jk,jl), tl_bdy(jl))927 980 928 981 ! use additional request 982 ! change unit and apply factor 983 CALL var_chg_unit(tl_segvar1(jvar,jk,jl)) 984 929 985 ! forced min and max value 930 986 CALL var_limit_value(tl_segvar1(jvar,jk,jl)) … … 933 989 CALL filter_fill_value(tl_segvar1(jvar,jk,jl)) 934 990 935 ! extrapolate 936 CALL extrap_fill_value( tl_segvar1(jvar,jk,jl), & 937 & id_iext=in_extrap, & 938 & id_jext=in_extrap, & 939 & id_kext=in_extrap ) 991 IF( .NOT. ln_extrap )THEN 992 ! use mask 993 SELECT CASE(TRIM(tl_segvar1(jvar,jk,jl)%c_point)) 994 CASE DEFAULT !'T' 995 jpoint=jp_T 996 CASE('U') 997 jpoint=jp_U 998 CASE('V') 999 jpoint=jp_V 1000 CASE('F') 1001 jpoint=jp_F 1002 END SELECT 1003 1004 CALL create_boundary_use_mask(tl_segvar1(jvar,jk,jl), & 1005 & tl_seglvl1(jpoint,jk,jl)) 1006 ENDIF 1007 1008 ! swap dimension order 1009 CALL boundary_swap(tl_segvar1(jvar,jk,jl), tl_bdy(jl)) 940 1010 941 1011 ENDDO … … 944 1014 ! create file structure 945 1015 ! set file namearray of level variable structure 946 IF( ASSOCIATED(tl_time%d_value) )THEN 947 cl_fmt="('y',i0.4,'m',i0.2,'d',i0.2)" 948 cl_date=date_print( var_to_date(tl_time), cl_fmt ) 949 950 cl_bdyout=boundary_set_filename( TRIM(cn_fileout), & 951 & TRIM(tl_bdy(jl)%c_card), jk, TRIM(cl_date) ) 1016 IF( tl_bdy(jl)%i_nseg > 1 )THEN 1017 IF( ASSOCIATED(tl_time%d_value) )THEN 1018 cl_fmt="('y',i0.4,'m',i0.2,'d',i0.2)" 1019 tl_date=var_to_date(tl_time) 1020 tl_date=tl_date+dn_dayofs 1021 cl_date=date_print( tl_date, cl_fmt ) 1022 1023 cl_bdyout=boundary_set_filename( TRIM(cn_fileout), & 1024 & TRIM(tl_bdy(jl)%c_card), jk,& 1025 & cd_date=TRIM(cl_date) ) 1026 ELSE 1027 cl_bdyout=boundary_set_filename( TRIM(cn_fileout), & 1028 & TRIM(tl_bdy(jl)%c_card), jk ) 1029 ENDIF 952 1030 ELSE 953 cl_bdyout=boundary_set_filename( TRIM(cn_fileout), & 954 & TRIM(tl_bdy(jl)%c_card), jk ) 1031 IF( ASSOCIATED(tl_time%d_value) )THEN 1032 cl_fmt="('y',i0.4,'m',i0.2,'d',i0.2)" 1033 tl_date=var_to_date(tl_time) 1034 tl_date=tl_date+dn_dayofs 1035 cl_date=date_print( tl_date, cl_fmt ) 1036 1037 cl_bdyout=boundary_set_filename( TRIM(cn_fileout), & 1038 & TRIM(tl_bdy(jl)%c_card), & 1039 & cd_date=TRIM(cl_date) ) 1040 ELSE 1041 cl_bdyout=boundary_set_filename( TRIM(cn_fileout), & 1042 & TRIM(tl_bdy(jl)%c_card) ) 1043 ENDIF 955 1044 ENDIF 956 1045 ! … … 960 1049 tl_dim(:)=var_max_dim(tl_segvar1(:,jk,jl)) 961 1050 962 CALL dim_unorder(tl_dim(:))963 1051 SELECT CASE(TRIM(tl_bdy(jl)%c_card)) 964 1052 CASE DEFAULT ! 'north','south' 965 1053 cl_dimorder='xyzt' 966 CALL dim_reorder(tl_dim(:),TRIM(cl_dimorder))967 1054 CASE('east','west') 968 1055 cl_dimorder='yxzt' 969 CALL dim_reorder(tl_dim(:),TRIM(cl_dimorder))970 ! reorder coordinates dimension971 CALL var_reorder(tl_lon1,TRIM(cl_dimorder))972 CALL var_reorder(tl_lat1,TRIM(cl_dimorder))973 ! reorder other variable dimension974 DO jvar=1,tl_multi%i_nvar975 CALL var_reorder(tl_segvar1(jvar,jk,jl),TRIM(cl_dimorder))976 ENDDO977 1056 END SELECT 978 1057 … … 992 1071 ENDIF 993 1072 1073 1074 994 1075 IF( tl_dim(3)%l_use )THEN 995 ! add depth 996 CALL file_add_var(tl_fileout, tl_depth) 1076 IF( ASSOCIATED(tl_depth%d_value) )THEN 1077 ! add depth 1078 CALL file_add_var(tl_fileout, tl_depth) 1079 ENDIF 997 1080 ENDIF 998 1081 999 1082 IF( tl_dim(4)%l_use )THEN 1000 ! add time 1001 CALL file_add_var(tl_fileout, tl_time) 1083 IF( ASSOCIATED(tl_time%d_value) )THEN 1084 ! add time 1085 CALL file_add_var(tl_fileout, tl_time) 1086 ENDIF 1002 1087 ENDIF 1003 1088 1004 1089 ! add other variable 1005 DO jvar= 1,tl_multi%i_nvar1090 DO jvar=tl_multi%i_nvar,1,-1 1006 1091 CALL file_add_var(tl_fileout, tl_segvar1(jvar,jk,jl)) 1007 1092 CALL var_clean(tl_segvar1(jvar,jk,jl)) … … 1048 1133 1049 1134 ! write file 1050 CALL iom_write_file(tl_fileout )1135 CALL iom_write_file(tl_fileout, cl_dimorder) 1051 1136 1052 1137 ! close file … … 1066 1151 DEALLOCATE( tl_segdom1 ) 1067 1152 DEALLOCATE( tl_segvar1 ) 1153 CALL var_clean(tl_seglvl1(:,:,:)) 1154 DEALLOCATE( tl_seglvl1 ) 1155 1068 1156 1069 1157 CALL mpp_clean(tl_coord1) … … 1082 1170 !> 1083 1171 !> @author J.Paul 1084 !> - November, 2013- Initial Version1172 !> @date November, 2013 - Initial Version 1085 1173 !> @date September, 2014 1086 1174 !> - take into account grid point to compute boundary indices … … 1186 1274 !------------------------------------------------------------------- 1187 1275 !> @brief 1188 !> This subroutine get coordinates over bou dnary domain1276 !> This subroutine get coordinates over boundary domain 1189 1277 !> 1190 1278 !> @author J.Paul 1191 !> - November, 2013- Initial Version 1192 !> @date September, 2014 - take into account grid point 1279 !> @date November, 2013 - Initial Version 1280 !> @date September, 2014 1281 !> - take into account grid point 1193 1282 !> 1194 1283 !> @param[in] td_coord1 coordinates file structure … … 1237 1326 !------------------------------------------------------------------- 1238 1327 !> @brief 1239 !> This subroutine interpolate variable o verboundary1328 !> This subroutine interpolate variable on boundary 1240 1329 !> 1241 1330 !> @details 1242 1331 !> 1243 1332 !> @author J.Paul 1244 !> - Nov, 2013- Initial Version1333 !> @date November, 2013 - Initial Version 1245 1334 !> 1246 1335 !> @param[inout] td_var variable structure … … 1296 1385 1297 1386 ! extrapolate variable 1298 CALL extrap_fill_value( td_var , id_iext=il_iext, id_jext=il_jext)1387 CALL extrap_fill_value( td_var ) 1299 1388 1300 1389 ! interpolate Bathymetry … … 1303 1392 1304 1393 ! remove extraband 1305 CALL extrap_del_extrabands(td_var, il_iext*id_rho(jp_I), il_jext*id_rho(jp_J)) 1394 CALL extrap_del_extrabands(td_var, il_iext*id_rho(jp_I), & 1395 & il_jext*id_rho(jp_J)) 1306 1396 1307 1397 END SUBROUTINE create_boundary_interp … … 1317 1407 !> 1318 1408 !> @author J.Paul 1319 !> - November, 2013- Initial Version1409 !> @date November, 2013 - Initial Version 1320 1410 !> 1321 1411 !> @param[in] td_var variable structure … … 1422 1512 !> 1423 1513 !> @author J.Paul 1424 !> - November, 2013- Initial Version1514 !> @date November, 2013 - Initial Version 1425 1515 !> 1426 1516 !> @param[inout] td_var variable structure … … 1475 1565 !> 1476 1566 !> @author J.Paul 1477 !> - November, 2013- Initial Version1567 !> @date November, 2013 - Initial Version 1478 1568 !> 1479 1569 !> @param[in] td_level array of level variable structure … … 1537 1627 !> 1538 1628 !> @author J.Paul 1539 !> - November, 2014- Initial Version1629 !> @date November, 2014 - Initial Version 1540 1630 !> 1541 1631 !> @param[in] td_mpp mpp structure … … 1588 1678 !> 1589 1679 !> @author J.Paul 1590 !> - November, 2014- Initial Version1680 !> @date November, 2014 - Initial Version 1591 1681 !> 1592 1682 !> @param[in] td_mpp mpp structure -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/create_coord.f90
r5037 r6487 24 24 !> @endcode 25 25 !> 26 !> @note 27 !> you could find a template of the namelist in templates directory. 28 !> 26 29 !> create_coord.nam comprise 6 namelists:<br/> 27 30 !> - logger namelist (namlog) … … 39 42 !> - cn_logfile : log filename 40 43 !> - cn_verbosity : verbosity ('trace','debug','info', 41 !> 'warning','error','fatal' )44 !> 'warning','error','fatal','none') 42 45 !> - in_maxerror : maximum number of error allowed 43 46 !> … … 54 57 !> - cn_varinfo : list of variable and extra information about request(s) 55 58 !> to be used.<br/> 56 !> each elements of *cn_varinfo* is a string character.<br/> 59 !> each elements of *cn_varinfo* is a string character 60 !> (separated by ',').<br/> 57 61 !> it is composed of the variable name follow by ':', 58 62 !> then request(s) to be used on this variable.<br/> 59 63 !> request could be: 60 !> - int erpolation method61 !> - ext rapolation method62 !> - f ilter method64 !> - int = interpolation method 65 !> - ext = extrapolation method 66 !> - flt = filter method 63 67 !> 64 68 !> requests must be separated by ';' .<br/> … … 68 72 !> @ref extrap and @ref filter modules.<br/> 69 73 !> 70 !> Example: 'votemper: linear; hann(2,3);dist_weight',71 !> 'vosaline: cubic'<br/>74 !> Example: 'votemper: int=linear; flt=hann(2,3); ext=dist_weight', 75 !> 'vosaline: int=cubic'<br/> 72 76 !> @note 73 77 !> If you do not specify a method which is required, … … 90 94 !> 91 95 !> * _output namelist (namout)_: 92 !> - cn_fileout : output coordinate file 96 !> - cn_fileout : output coordinate file name 93 97 !> 94 98 !> @author J.Paul … … 152 156 TYPE(TFILE) :: tl_fileout 153 157 154 ! check155 ! INTEGER(i4) :: il_imin0156 ! INTEGER(i4) :: il_imax0157 ! INTEGER(i4) :: il_jmin0158 ! INTEGER(i4) :: il_jmax0159 ! INTEGER(i4) , DIMENSION(2,2) :: il_ind2160 ! TYPE(TMPP) :: tl_mppout161 162 158 ! loop indices 163 159 INTEGER(i4) :: ji … … 165 161 166 162 ! namelist variable 163 ! namlog 167 164 CHARACTER(LEN=lc) :: cn_logfile = 'create_coord.log' 168 165 CHARACTER(LEN=lc) :: cn_verbosity = 'warning' 169 166 INTEGER(i4) :: in_maxerror = 5 170 167 168 ! namcfg 169 CHARACTER(LEN=lc) :: cn_varcfg = '../cfg/variable.cfg' 170 171 ! namcrs 171 172 CHARACTER(LEN=lc) :: cn_coord0 = '' 172 173 INTEGER(i4) :: in_perio0 = -1 173 174 174 CHARACTER(LEN=lc) :: cn_varcfg = '../cfg/variable.cfg' 175 175 ! namvar 176 176 CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = '' 177 177 178 !namnst 178 179 INTEGER(i4) :: in_imin0 = 0 179 180 INTEGER(i4) :: in_imax0 = 0 … … 183 184 INTEGER(i4) :: in_rhoj = 1 184 185 186 !namout 185 187 CHARACTER(LEN=lc) :: cn_fileout= 'coord_fine.nc' 186 188 !------------------------------------------------------------------- … … 305 307 306 308 il_offset(:,:,:)=create_coord_get_offset(il_rho(:)) 307 308 309 ENDIF 309 310 … … 348 349 CALL dom_del_extra( tl_var(ji), tl_dom, il_rho(:), .true. ) 349 350 350 ! do not add ghost cell.351 ! ghost cell already replace by value for coordinates352 ! CALL grid_add_ghost(tl_var(ji),tl_dom%i_ghost(:,:))353 354 351 ! filter 355 352 CALL filter_fill_value(tl_var(ji)) … … 375 372 376 373 ! add variables 377 DO ji= 1,il_nvar374 DO ji=il_nvar,1,-1 378 375 CALL file_add_var(tl_fileout, tl_var(ji)) 376 CALL var_clean(tl_var(ji)) 379 377 ENDDO 380 381 ! recompute some attribute382 378 383 379 ! add some attribute … … 440 436 441 437 CALL file_clean(tl_fileout) 442 443 ! ! check domain444 ! tl_coord0=mpp_init( file_init(TRIM(cn_coord0)), id_perio=in_perio0)445 ! tl_mppout=mpp_init( file_init(TRIM(cn_fileout)) )446 ! CALL grid_get_info(tl_coord0)447 ! CALL iom_mpp_open(tl_mppout)448 !449 ! il_ind2(:,:)=grid_get_coarse_index( tl_coord0, tl_mppout, &450 ! & id_rho=il_rho(:) )451 !452 ! il_imin0=il_ind2(1,1) ; il_imax0=il_ind2(1,2)453 ! il_jmin0=il_ind2(2,1) ; il_jmax0=il_ind2(2,2)454 !455 ! IF( il_imin0 /= in_imin0 .OR. &456 ! & il_imax0 /= in_imax0 .OR. &457 ! & il_jmin0 /= in_jmin0 .OR. &458 ! & il_jmax0 /= in_jmax0 )THEN459 ! CALL logger_debug("CREATE COORD: output indices ("//&460 ! & TRIM(fct_str(il_imin0))//","//&461 ! & TRIM(fct_str(il_imax0))//") ("//&462 ! & TRIM(fct_str(il_jmin0))//","//&463 ! & TRIM(fct_str(il_jmax0))//")" )464 ! CALL logger_debug("CREATE COORD: input indices ("//&465 ! & TRIM(fct_str(in_imin0))//","//&466 ! & TRIM(fct_str(in_imax0))//") ("//&467 ! & TRIM(fct_str(in_jmin0))//","//&468 ! & TRIM(fct_str(in_jmax0))//")" )469 ! CALL logger_fatal("CREATE COORD: output domain not confrom "//&470 ! & "with input indices")471 ! ENDIF472 !473 ! CALL iom_mpp_close(tl_coord0)474 ! CALL iom_mpp_close(tl_mppout)475 438 476 439 ! close log file … … 539 502 !> @param[in] id_iext number of points to be extrapolated in i-direction 540 503 !> @param[in] id_jext number of points to be extrapolated in j-direction 504 !> 505 !> @todo check if mask is really needed 541 506 !------------------------------------------------------------------- 542 507 SUBROUTINE create_coord_interp( td_var, & … … 626 591 627 592 ! extrapolate variable 628 CALL extrap_fill_value( td_var , id_iext=il_iext, id_jext=il_jext)593 CALL extrap_fill_value( td_var ) 629 594 630 595 ! interpolate variable -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/create_restart.f90
r5037 r6487 25 25 !> @endcode 26 26 !> 27 !> @note 28 !> you could find a template of the namelist in templates directory. 29 !> 27 30 !> create_restart.nam comprise 9 namelists:<br/> 28 31 !> - logger namelist (namlog) … … 43 46 !> - cn_logfile : log filename 44 47 !> - cn_verbosity : verbosity ('trace','debug','info', 45 !> 'warning','error','fatal' )48 !> 'warning','error','fatal','none') 46 49 !> - in_maxerror : maximum number of error allowed 47 50 !> … … 59 62 !> - cn_bathy1 : bathymetry file 60 63 !> - in_perio1 : NEMO periodicity index 61 !> - in_extrap : number of land point to be extrapolated62 !> before writing file63 64 !> 64 65 !> * _vertical grid namelist (namzgr)_:<br/> … … 83 84 !> - cn_varinfo : list of variable and extra information about request(s) 84 85 !> to be used.<br/> 85 !> each elements of *cn_varinfo* is a string character.<br/> 86 !> each elements of *cn_varinfo* is a string character 87 !> (separated by ',').<br/> 86 88 !> it is composed of the variable name follow by ':', 87 89 !> then request(s) to be used on this variable.<br/> 88 90 !> request could be: 89 !> - interpolation method 90 !> - extrapolation method 91 !> - filter method 92 !> - > minimum value 93 !> - < maximum value 91 !> - int = interpolation method 92 !> - ext = extrapolation method 93 !> - flt = filter method 94 !> - min = minimum value 95 !> - max = maximum value 96 !> - unt = new units 97 !> - unf = unit scale factor (linked to new units) 94 98 !> 95 99 !> requests must be separated by ';'.<br/> … … 98 102 !> informations about available method could be find in @ref interp, 99 103 !> @ref extrap and @ref filter.<br/> 100 !> Example: 'votemper: linear; hann; dist_weight','vosaline:cubic'104 !> Example: 'votemper: int=linear; flt=hann; ext=dist_weight','vosaline: int=cubic' 101 105 !> @note 102 106 !> If you do not specify a method which is required, … … 136 140 !> * _output namelist (namout)_:<br/> 137 141 !> - cn_fileout : output file 138 !> - in_nproc : total number of processor to be used142 !> - ln_extrap : extrapolate land point or not 139 143 !> - in_niproc : i-direction number of processor 140 144 !> - in_njproc : j-direction numebr of processor 145 !> - in_nproc : total number of processor to be used 141 146 !> - cn_type : output format ('dimg', 'cdf') 142 147 !> … … 148 153 !> - offset computed considering grid point 149 154 !> - add attributes in output variable 155 !> @date June, 2015 156 !> - extrapolate all land points, and add ln_extrap in namelist. 157 !> - allow to change unit. 150 158 !> 151 159 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 165 173 USE iom ! I/O manager 166 174 USE grid ! grid manager 167 USE vgrid ! vertical grid manager175 USE vgrid ! vertical grid manager 168 176 USE extrap ! extrapolation manager 169 177 USE interp ! interpolation manager … … 249 257 CHARACTER(LEN=lc) :: cn_bathy1 = '' 250 258 INTEGER(i4) :: in_perio1 = -1 251 INTEGER(i4) :: in_extrap = 0252 259 253 260 !namzgr … … 279 286 ! namout 280 287 CHARACTER(LEN=lc) :: cn_fileout = 'restart.nc' 288 LOGICAL :: ln_extrap = .FALSE. 281 289 INTEGER(i4) :: in_nproc = 0 282 290 INTEGER(i4) :: in_niproc = 0 … … 301 309 & cn_coord1, & !< coordinate file 302 310 & cn_bathy1, & !< bathymetry file 303 & in_perio1, & !< periodicity index 304 & in_extrap 311 & in_perio1 !< periodicity index 305 312 306 313 NAMELIST /namzgr/ & … … 332 339 NAMELIST /namout/ & !< output namlist 333 340 & cn_fileout, & !< fine grid bathymetry file 334 & in_nproc, & !< number of processor to be used341 & ln_extrap, & !< extrapolate or not 335 342 & in_niproc, & !< i-direction number of processor 336 343 & in_njproc, & !< j-direction numebr of processor 344 & in_nproc, & !< number of processor to be used 337 345 & cn_type !< output type format (dimg, cdf) 338 346 !------------------------------------------------------------------- … … 347 355 CALL GET_COMMAND_ARGUMENT(1,cl_namelist) !f03 intrinsec 348 356 ENDIF 349 357 350 358 ! read namelist 351 359 INQUIRE(FILE=TRIM(cl_namelist), EXIST=ll_exist) … … 434 442 ! check 435 443 ! check output file do not already exist 436 cl_fileout=file_rename(cn_fileout,1) 444 IF( in_nproc > 0 )THEN 445 cl_fileout=file_rename(cn_fileout,1) 446 ELSE 447 cl_fileout=file_rename(cn_fileout) 448 ENDIF 437 449 INQUIRE(FILE=TRIM(cl_fileout), EXIST=ll_exist) 438 450 IF( ll_exist )THEN … … 468 480 & il_rho(:) ) 469 481 470 ! compute level 471 ALLOCATE(tl_level(ip_npoint)) 472 tl_level(:)=vgrid_get_level(tl_bathy1, cl_namelist ) 473 474 ! remove ghost cell 482 ! fine grid ghost cell 475 483 il_xghost(:,:)=grid_get_ghost(tl_bathy1) 476 DO ji=1,ip_npoint477 CALL grid_del_ghost(tl_level(ji), il_xghost(:,:))478 ENDDO479 480 ! clean481 CALL mpp_clean(tl_bathy1)482 484 483 485 ! work on variables … … 514 516 tl_var(jvar) = create_restart_matrix( & 515 517 & tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj), tl_coord1, & 516 & in_nlevel, tl_level(:) ) 518 & in_nlevel, il_xghost(:,:) ) 519 520 ! add ghost cell 521 CALL grid_add_ghost(tl_var(jvar), il_xghost(:,:)) 517 522 518 523 ENDDO … … 535 540 ! open mpp file 536 541 CALL iom_mpp_open(tl_mpp) 542 537 543 538 544 ! get or check depth value … … 579 585 DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar 580 586 581 WRITE(*,'(2x,a,a)') "work on variable "//&587 WRITE(*,'(2x,a,a)') "work on (extract) variable "//& 582 588 & TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name) 583 589 … … 600 606 CALL att_clean(tl_att) 601 607 602 ! use mask603 CALL create_restart_mask(tl_var(jvar), tl_level(:))604 605 608 ! add ghost cell 606 CALL grid_add_ghost( tl_var(jvar), tl_dom1%i_ghost(:,:))609 CALL grid_add_ghost(tl_var(jvar), tl_dom1%i_ghost(:,:)) 607 610 608 611 ENDDO … … 631 634 DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar 632 635 633 WRITE(*,'(2x,a,a)') "work on variable "//&636 WRITE(*,'(2x,a,a)') "work on (interp) variable "//& 634 637 & TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name) 635 638 … … 646 649 & id_rho=il_rho(:), & 647 650 & cd_point=TRIM(tl_var(jvar)%c_point)) 648 649 651 650 652 ! interpolate variable 651 CALL create_restart_interp(tl_var(jvar), tl_level(:), &653 CALL create_restart_interp(tl_var(jvar), & 652 654 & il_rho(:), & 653 655 & id_offset=il_offset(:,:)) … … 675 677 CALL att_clean(tl_att) 676 678 677 ! use mask678 CALL create_restart_mask(tl_var(jvar), tl_level(:))679 680 679 ! add ghost cell 681 CALL grid_add_ghost( tl_var(jvar), il_xghost(:,:) ) 682 683 680 CALL grid_add_ghost(tl_var(jvar), il_xghost(:,:)) 684 681 ENDDO 685 682 … … 705 702 CALL mpp_clean(tl_coord0) 706 703 704 IF( .NOT. ln_extrap )THEN 705 ! compute level 706 ALLOCATE(tl_level(ip_npoint)) 707 tl_level(:)=vgrid_get_level(tl_bathy1, cl_namelist ) 708 ENDIF 709 710 ! clean 711 CALL mpp_clean(tl_bathy1) 712 707 713 ! use additional request 708 714 DO jvar=1,il_nvar 709 715 716 ! change unit and apply factor 717 CALL var_chg_unit(tl_var(jvar)) 718 710 719 ! forced min and max value 711 720 CALL var_limit_value(tl_var(jvar)) … … 714 723 CALL filter_fill_value(tl_var(jvar)) 715 724 716 ! extrapolate717 CALL extrap_fill_value(tl_var(jvar), id_iext=in_extrap, &718 & id_jext=in_extrap, &719 & id_kext=in_extrap)725 IF( .NOT. ln_extrap )THEN 726 ! use mask 727 CALL create_restart_mask(tl_var(jvar), tl_level(:)) 728 ENDIF 720 729 721 730 ENDDO … … 724 733 IF( in_niproc == 0 .AND. & 725 734 & in_njproc == 0 .AND. & 726 & in_nproc 735 & in_nproc == 0 )THEN 727 736 in_niproc = 1 728 737 in_njproc = 1 … … 782 791 CALL mpp_add_var(tl_mppout, tl_depth) 783 792 ELSE 784 CALL logger_ error("CREATE RESTART: no value for depth variable.")793 CALL logger_warn("CREATE RESTART: no value for depth variable.") 785 794 ENDIF 786 795 ENDIF … … 792 801 CALL mpp_add_var(tl_mppout, tl_time) 793 802 ELSE 794 CALL logger_ error("CREATE RESTART: no value for time variable.")803 CALL logger_warn("CREATE RESTART: no value for time variable.") 795 804 ENDIF 796 805 ENDIF … … 798 807 799 808 ! add other variable 800 DO jvar= 1,il_nvar809 DO jvar=il_nvar,1,-1 801 810 ! check if variable already add 802 811 il_index=var_get_index(tl_mppout%t_proc(1)%t_var(:), tl_var(jvar)%c_name) … … 807 816 ENDDO 808 817 809 ! DO ji=1,4810 ! CALL grid_add_ghost( tl_level(ji), il_xghost(:,:) )811 ! CALL var_clean(tl_level(ji))812 ! ENDDO813 814 818 ! add some attribute 815 819 tl_att=att_init("Created_by","SIREN create_restart") … … 839 843 ENDIF 840 844 845 ! print 846 CALL mpp_print(tl_mppout) 847 841 848 ! create file 842 849 CALL iom_mpp_create(tl_mppout) … … 847 854 CALL iom_mpp_close(tl_mppout) 848 855 849 ! print850 CALL mpp_print(tl_mppout)851 852 856 ! clean 853 857 CALL att_clean(tl_att) 854 858 CALL var_clean(tl_var(:)) 855 859 DEALLOCATE(tl_var) 856 CALL var_clean(tl_level(:)) 857 DEALLOCATE(tl_level) 860 IF( .NOT. ln_extrap )THEN 861 CALL var_clean(tl_level(:)) 862 DEALLOCATE(tl_level) 863 ENDIF 858 864 859 865 CALL mpp_clean(tl_mppout) … … 876 882 !> 877 883 !> @author J.Paul 878 !> - November, 2013- Initial Version 884 !> @date November, 2013 - Initial Version 885 !> @date June, 2015 886 !> - do not use level anymore 879 887 !> 880 888 !> @param[in] td_var variable structure 881 889 !> @param[in] td_coord coordinate file structure 882 890 !> @param[in] id_nlevel number of vertical level 883 !> @param[in] td_level array of level on T,U,V,F point (variable structure)891 !> @param[in] id_xghost ghost cell array 884 892 !> @return variable structure 885 893 !------------------------------------------------------------------- 886 FUNCTION create_restart_matrix(td_var, td_coord, id_nlevel, td_level)894 FUNCTION create_restart_matrix(td_var, td_coord, id_nlevel, id_xghost) 887 895 IMPLICIT NONE 888 896 ! Argument 889 TYPE(TVAR) , INTENT(IN) :: td_var890 TYPE(TMPP) , INTENT(IN) :: td_coord891 INTEGER(i4) , INTENT(IN) :: id_nlevel892 TYPE(TVAR), DIMENSION(:), INTENT(IN) :: td_level897 TYPE(TVAR) , INTENT(IN) :: td_var 898 TYPE(TMPP) , INTENT(IN) :: td_coord 899 INTEGER(i4) , INTENT(IN) :: id_nlevel 900 INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_xghost 893 901 894 902 ! function … … 899 907 INTEGER(i4) , DIMENSION(3) :: il_size 900 908 INTEGER(i4) , DIMENSION(3) :: il_rest 901 INTEGER(i4) , DIMENSION(2,2) :: il_xghost902 909 903 910 INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_ishape … … 915 922 !---------------------------------------------------------------- 916 923 917 ! look for ghost cell918 il_xghost(:,:)=grid_get_ghost( td_coord )919 920 924 ! write value on grid 921 925 ! get matrix dimension … … 929 933 930 934 ! remove ghost cell 931 tl_dim(jp_I)%i_len=tl_dim(jp_I)%i_len - SUM(i l_xghost(jp_I,:))*ip_ghost932 tl_dim(jp_J)%i_len=tl_dim(jp_J)%i_len - SUM(i l_xghost(jp_J,:))*ip_ghost935 tl_dim(jp_I)%i_len=tl_dim(jp_I)%i_len - SUM(id_xghost(jp_I,:))*ip_ghost 936 tl_dim(jp_J)%i_len=tl_dim(jp_J)%i_len - SUM(id_xghost(jp_J,:))*ip_ghost 933 937 934 938 ! split output domain in N subdomain depending of matrix dimension … … 992 996 DEALLOCATE(dl_value) 993 997 994 ! use mask995 CALL create_restart_mask(create_restart_matrix, td_level(:))996 997 ! add ghost cell998 CALL grid_add_ghost( create_restart_matrix, il_xghost(:,:) )999 1000 998 ! clean 1001 999 DEALLOCATE(il_ishape) … … 1009 1007 !> 1010 1008 !> @author J.Paul 1011 !> - November, 2013- Initial Version1009 !> @date November, 2013 - Initial Version 1012 1010 !> 1013 1011 !> @param[inout] td_var variable structure … … 1071 1069 !> 1072 1070 !> @author J.Paul 1073 !> - Nov, 2013- Initial Version 1071 !> @date November, 2013 - Initial Version 1072 !> @date June, 2015 1073 !> - do not use level anymore (for extrapolation) 1074 1074 !> 1075 1075 !> @param[inout] td_var variable structure 1076 !> @param[inout] td_level fine grid level, array of variable structure1077 1076 !> @param[in] id_rho array of refinment factor 1078 1077 !> @param[in] id_offset array of offset between fine and coarse grid … … 1080 1079 !> @param[in] id_jext j-direction size of extra bands (default=im_minext) 1081 1080 !------------------------------------------------------------------- 1082 SUBROUTINE create_restart_interp( td_var, td_level,&1081 SUBROUTINE create_restart_interp( td_var, & 1083 1082 & id_rho, & 1084 1083 & id_offset, & … … 1089 1088 ! Argument 1090 1089 TYPE(TVAR) , INTENT(INOUT) :: td_var 1091 TYPE(TVAR) , DIMENSION(:) , INTENT(INOUT) :: td_level1092 1090 INTEGER(i4), DIMENSION(:) , INTENT(IN ) :: id_rho 1093 1091 INTEGER(i4), DIMENSION(:,:), INTENT(IN ) :: id_offset … … 1119 1117 il_jext=2 1120 1118 ENDIF 1121 1122 1119 ! work on variable 1123 1120 ! add extraband … … 1125 1122 1126 1123 ! extrapolate variable 1127 CALL extrap_fill_value( td_var, td_level(:), & 1128 & id_offset(:,:), & 1129 & id_rho(:), & 1130 & id_iext=il_iext, id_jext=il_jext ) 1124 CALL extrap_fill_value( td_var ) 1131 1125 1132 1126 ! interpolate variable … … 1146 1140 !> 1147 1141 !> @author J.Paul 1148 !> - November, 2014- Initial Version1142 !> @date November, 2014 - Initial Version 1149 1143 !> 1150 1144 !> @param[in] td_mpp mpp structure … … 1197 1191 !> 1198 1192 !> @author J.Paul 1199 !> - November, 2014- Initial Version1193 !> @date November, 2014 - Initial Version 1200 1194 !> 1201 1195 !> @param[in] td_mpp mpp structure … … 1220 1214 1221 1215 ! get or check depth value 1216 1222 1217 IF( td_mpp%t_proc(1)%i_timeid /= 0 )THEN 1223 1218 -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/dimension.f90
r5037 r6487 78 78 !> 79 79 !> This subroutine filled dimension structure with unused dimension, 80 !> then switch from " unordered" dimension to "ordered" dimension.<br/>80 !> then switch from "disordered" dimension to "ordered" dimension.<br/> 81 81 !> The dimension structure return will be:<br/> 82 82 !> tl_dim(1) => 'X', i_len=10, l_use=T, l_uld=F<br/> … … 94 94 !> - cl_neworder : character(len=4) (example: 'yxzt') 95 95 !> 96 !> to switch dimension array from ordered dimension to unordered96 !> to switch dimension array from ordered dimension to disordered 97 97 !> dimension:<br/> 98 98 !> @code 99 !> CALL dim_ unorder(tl_dim(:))99 !> CALL dim_disorder(tl_dim(:)) 100 100 !> @endcode 101 101 !> … … 111 111 !> CALL dim_reshape_2xyzt(tl_dim(:), value(:,:,:,:)) 112 112 !> @endcode 113 !> - value must be a 4D array of real(8) value " unordered"114 !> 115 !> to reshape array of value in " unordered" dimension:<br/>113 !> - value must be a 4D array of real(8) value "disordered" 114 !> 115 !> to reshape array of value in "disordered" dimension:<br/> 116 116 !> @code 117 117 !> CALL dim_reshape_xyzt2(tl_dim(:), value(:,:,:,:)) … … 123 123 !> CALL dim_reorder_2xyzt(tl_dim(:), tab(:)) 124 124 !> @endcode 125 !> - tab must be a 1D array with 4 elements " unordered".125 !> - tab must be a 1D array with 4 elements "disordered". 126 126 !> It could be composed of character, integer(4), or logical 127 127 !> 128 !> to reorder a 1D array of 4 elements in " unordered" dimension:<br/>129 !> @code 130 !> CALL dim_reorder_ 2xyzt(tl_dim(:), tab(:))128 !> to reorder a 1D array of 4 elements in "disordered" dimension:<br/> 129 !> @code 130 !> CALL dim_reorder_xyzt2(tl_dim(:), tab(:)) 131 131 !> @endcode 132 132 !> - tab must be a 1D array with 4 elements "ordered". … … 173 173 PUBLIC :: dim_print !< print dimension information 174 174 PUBLIC :: dim_copy !< copy dimension structure 175 PUBLIC :: dim_reorder !< filled dimension structure to switch from unordered to ordered dimension176 PUBLIC :: dim_ unorder !< switch dimension array from ordered to unordered dimension175 PUBLIC :: dim_reorder !< filled dimension structure to switch from disordered to ordered dimension 176 PUBLIC :: dim_disorder !< switch dimension array from ordered to disordered dimension 177 177 PUBLIC :: dim_fill_unused !< filled dimension structure with unused dimension 178 178 PUBLIC :: dim_reshape_2xyzt !< reshape array dimension to ('x','y','z','t') … … 321 321 !> @author J.Paul 322 322 !> @date November, 2013 - Initial Version 323 !> @date September, 2014 - do not check if dimension used 323 !> @date September, 2014 324 !> - do not check if dimension used 324 325 !> 325 326 !> @param[in] td_dim array of dimension structure … … 502 503 !> Optionally length could be inform, as well as short name and if dimension 503 504 !> is unlimited or not.<br/> 504 !> define dimension is supposed to be used. 505 !> 506 !> @author J.Paul 507 !> @date November, 2013 - Initial Version 505 !> By default, define dimension is supposed to be used. 506 !> Optionally you could force a defined dimension to be unused. 507 !> 508 !> @author J.Paul 509 !> @date November, 2013 - Initial Version 510 !> @date February, 2015 511 !> - add optional argument to define dimension unused 512 !> @date July, 2015 513 !> - Bug fix: inform order to disorder table instead of disorder to order 514 !> table 508 515 ! 509 516 !> @param[in] cd_name dimension name … … 511 518 !> @param[in] ld_uld dimension unlimited 512 519 !> @param[in] cd_sname dimension short name 520 !> @param[in] ld_uld dimension use or not 513 521 !> @return dimension structure 514 522 !------------------------------------------------------------------- 515 TYPE(TDIM) FUNCTION dim_init( cd_name, id_len, ld_uld, cd_sname )523 TYPE(TDIM) FUNCTION dim_init( cd_name, id_len, ld_uld, cd_sname, ld_use) 516 524 IMPLICIT NONE 517 525 … … 521 529 LOGICAL, INTENT(IN), OPTIONAL :: ld_uld 522 530 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_sname 531 LOGICAL, INTENT(IN), OPTIONAL :: ld_use 523 532 524 533 ! local variable … … 543 552 544 553 ! define dimension is supposed to be used 545 dim_init%l_use=.TRUE. 554 IF( PRESENT(ld_use) )THEN 555 dim_init%l_use=ld_use 556 ELSE 557 dim_init%l_use=.TRUE. 558 ENDIF 546 559 547 560 IF( PRESENT(cd_sname) )THEN … … 590 603 ENDIF 591 604 592 ! get dimension order er index593 dim_init%i_ 2xyzt=SCAN(TRIM(cp_dimorder),TRIM(dim_init%c_sname))605 ! get dimension order indices 606 dim_init%i_xyzt2=SCAN(TRIM(cp_dimorder),TRIM(dim_init%c_sname)) 594 607 595 608 END FUNCTION dim_init … … 655 668 !> @author J.Paul 656 669 !> @date November, 2013 - Initial Version 670 !> @date July, 2015 671 !> - Bug fix: use order to disorder table (see dim_init) 657 672 !> 658 673 !> @param[in] td_dim array of dimension structure … … 686 701 ! search missing dimension 687 702 IF( INDEX(cl_dimin,TRIM(fct_lower(cp_dimorder(ji:ji)))) == 0 )THEN 688 ! search first empty dimension 689 il_ind(:)=MINLOC( tl_dim(:)%i_ 2xyzt, tl_dim(:)%i_2xyzt== 0 )703 ! search first empty dimension (see dim_init) 704 il_ind(:)=MINLOC( tl_dim(:)%i_xyzt2, tl_dim(:)%i_xyzt2 == 0 ) 690 705 691 706 ! put missing dimension instead of empty one … … 693 708 ! update output structure 694 709 tl_dim(il_ind(1))%c_name=fct_lower(cp_dimorder(ji:ji)) 695 tl_dim(il_ind(1))%i_ 2xyzt=ji710 tl_dim(il_ind(1))%i_xyzt2=ji 696 711 tl_dim(il_ind(1))%i_len=1 697 712 tl_dim(il_ind(1))%l_use=.FALSE. … … 711 726 !> This subroutine switch element of an array (4 elts) of dimension 712 727 !> structure 713 !> from unordered dimension to ordered dimension <br/>728 !> from disordered dimension to ordered dimension <br/> 714 729 !> 715 730 !> @details … … 722 737 !> @author J.Paul 723 738 !> @date November, 2013 - Initial Version 724 !> @date September, 2014 - allow to choose ordered dimension to be output 739 !> @date September, 2014 740 !> - allow to choose ordered dimension to be output 725 741 !> 726 742 !> @param[inout] td_dim array of dimension structure … … 811 827 !------------------------------------------------------------------- 812 828 !> @brief This subroutine switch dimension array from ordered dimension ('x','y','z','t') 813 !> to unordered dimension. <br/>829 !> to disordered dimension. <br/> 814 830 !> @details 815 831 !> Example: (/'x','y','z','t'/) => (/'z','x','t','y'/)<br/> … … 822 838 !> @param[inout] td_dim array of dimension structure 823 839 !------------------------------------------------------------------- 824 SUBROUTINE dim_ unorder(td_dim)840 SUBROUTINE dim_disorder(td_dim) 825 841 IMPLICIT NONE 826 842 ! Argument … … 835 851 836 852 IF( SIZE(td_dim(:)) /= ip_maxdim )THEN 837 CALL logger_error("DIM UNORDER: invalid dimension of array dimension.")853 CALL logger_error("DIM DISORDER: invalid dimension of array dimension.") 838 854 ELSE 839 855 ! add dummy xyzt2 id to unused dimension … … 868 884 ENDIF 869 885 870 END SUBROUTINE dim_ unorder886 END SUBROUTINE dim_disorder 871 887 !------------------------------------------------------------------- 872 888 !> @brief This function reshape real(8) 4D array … … 908 924 909 925 IF( SIZE(td_dim(:)) /= ip_maxdim )THEN 910 CALL logger_error("DIM RESHAPE 2 XYZT: invalid dimension of array dimension.") 926 CALL logger_error("DIM RESHAPE 2 XYZT: invalid dimension of "//& 927 & "array dimension.") 911 928 ELSE 912 929 … … 914 931 915 932 CALL logger_fatal( & 916 & " DIM RESHAPE 2 XYZT: you should have run dim_reorder &917 & before running RESHAPE" )933 & " DIM RESHAPE 2 XYZT: you should have run dim_reorder"// & 934 & " before running RESHAPE" ) 918 935 919 936 ENDIF … … 972 989 !------------------------------------------------------------------- 973 990 !> @brief This function reshape ordered real(8) 4D array with dimension 974 !> (/'x','y','z','t'/) to an " unordered" array.<br/>991 !> (/'x','y','z','t'/) to an "disordered" array.<br/> 975 992 !> @details 976 993 !> Example: (/'x','y','z','t'/) => (/'z','x','t','y'/) … … 1009 1026 1010 1027 IF( SIZE(td_dim(:)) /= ip_maxdim )THEN 1011 CALL logger_error("DIM RESHAPE XYZT 2: invalid dimension of array dimension.") 1028 CALL logger_error("DIM RESHAPE XYZT 2: invalid dimension of "//& 1029 & "array dimension.") 1012 1030 ELSE 1013 1031 … … 1015 1033 1016 1034 CALL logger_fatal( & 1017 & " DIM RESHAPE XYZT 2: you should have run dim_reorder &1018 & before running RESHAPE" )1035 & " DIM RESHAPE XYZT 2: you should have run dim_reorder"// & 1036 & " before running RESHAPE" ) 1019 1037 1020 1038 ENDIF … … 1104 1122 1105 1123 CALL logger_error( & 1106 & " DIM REORDER 2 XYZT: you should have run dim_reorder 1107 & before running REORDER" )1124 & " DIM REORDER 2 XYZT: you should have run dim_reorder"//& 1125 & " before running REORDER" ) 1108 1126 1109 1127 ENDIF … … 1116 1134 END FUNCTION dim__reorder_2xyzt_i4 1117 1135 !------------------------------------------------------------------- 1118 !> @brief This function unordered integer(4) 1D array to be suitable with1136 !> @brief This function disordered integer(4) 1D array to be suitable with 1119 1137 !> initial dimension order (ex: dimension read in file). 1120 1138 !> @note you must have run dim_reorder before use this subroutine … … 1143 1161 IF( SIZE(td_dim(:)) /= ip_maxdim .OR. & 1144 1162 & SIZE(id_arr(:)) /= ip_maxdim )THEN 1145 CALL logger_error("DIM REORDER XYZT 2: invalid dimension of array dimension"//&1146 & "or of array of value.")1163 CALL logger_error("DIM REORDER XYZT 2: invalid dimension of "//& 1164 & "array dimension or of array of value.") 1147 1165 ELSE 1148 1166 IF( ANY(td_dim(:)%i_xyzt2==0) )THEN 1149 1167 1150 1168 CALL logger_error( & 1151 & " DIM REORDER XYZT 2: you should have run dim_reorder &1152 & before running REORDER" )1169 & " DIM REORDER XYZT 2: you should have run dim_reorder"// & 1170 & " before running REORDER" ) 1153 1171 1154 1172 ENDIF … … 1166 1184 ! 1167 1185 !> @author J.Paul 1168 !> @date Nov , 2013 - Initial Version1186 !> @date November, 2013 - Initial Version 1169 1187 ! 1170 1188 !> @param[in] td_dim array of dimension structure … … 1193 1211 1194 1212 CALL logger_error( & 1195 & " DIM REORDER 2 XYZT: you should have run dim_reorder &1196 & before running REORDER" )1213 & " DIM REORDER 2 XYZT: you should have run dim_reorder"// & 1214 & " before running REORDER" ) 1197 1215 1198 1216 ENDIF … … 1205 1223 END FUNCTION dim__reorder_2xyzt_l 1206 1224 !------------------------------------------------------------------- 1207 !> @brief This function unordered logical 1D array to be suitable with1225 !> @brief This function disordered logical 1D array to be suitable with 1208 1226 !> initial dimension order (ex: dimension read in file). 1209 1227 !> @note you must have run dim_reorder before use this subroutine … … 1238 1256 1239 1257 CALL logger_error( & 1240 & " DIM REORDER XYZT 2: you should have run dim_reorder 1241 & 1258 & " DIM REORDER XYZT 2: you should have run dim_reorder"//& 1259 & " before running REORDER" ) 1242 1260 1243 1261 ENDIF … … 1294 1312 END FUNCTION dim__reorder_2xyzt_c 1295 1313 !------------------------------------------------------------------- 1296 !> @brief This function unordered string 1D array to be suitable with1314 !> @brief This function disordered string 1D array to be suitable with 1297 1315 !> initial dimension order (ex: dimension read in file). 1298 1316 !> @note you must have run dim_reorder before use this subroutine 1299 1317 ! 1300 1318 !> @author J.Paul 1301 !> @date Nov , 2013 - Initial Version1319 !> @date November, 2013 - Initial Version 1302 1320 ! 1303 1321 !> @param[in] td_dim array of dimension structure … … 1326 1344 IF( ANY(td_dim(:)%i_xyzt2==0) )THEN 1327 1345 CALL logger_error( & 1328 & " DIM REORDER XYZT 2: you should have run dim_reorder &1329 & before running REORDER" )1346 & " DIM REORDER XYZT 2: you should have run dim_reorder"// & 1347 & " before running REORDER" ) 1330 1348 1331 1349 ENDIF -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/docsrc/1_install.md
r5037 r6487 13 13 # Fortran Compiler 14 14 SIREN codes were succesfully tested with : 15 - ifort (version 1 2.0.4)16 - gfortran (version 4. 7.2 20121109)15 - ifort (version 15.0.1) 16 - gfortran (version 4.8.2 20140120) 17 17 <!-- - pgf95 (version 13.9-0) --> 18 18 -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/docsrc/3_codingRules.md
r5037 r6487 80 80 81 81 # Implicit none {#implicit} 82 All subroutines and functions will include an IMPLIC TINONE statement.82 All subroutines and functions will include an IMPLICIT NONE statement. 83 83 84 84 # Header {#header} -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/domain.f90
r5037 r6487 246 246 ! 247 247 !> @author J.Paul 248 !> - Nov, 2013- Initial Version248 !> @date November, 2013 - Initial Version 249 249 ! 250 250 !> @param[inout] td_dom dom structure … … 294 294 ! 295 295 !> @author J.Paul 296 !> - June, 2013- Initial Version296 !> @date June, 2013 - Initial Version 297 297 !> @date September, 2014 298 298 !> - add boundary index … … 362 362 363 363 IF( td_mpp%i_perio < 0 .OR. td_mpp%i_perio > 6 )THEN 364 CALL logger_error("DOM INIT: invalid grid periodicity. "//& 365 & "you should use grid_get_perio to compute it") 364 CALL logger_error("DOM INIT: invalid grid periodicity ("//& 365 & TRIM(fct_str(td_mpp%i_perio))//& 366 & ") you should use grid_get_perio to compute it") 366 367 ELSE 367 368 dom__init_mpp%i_perio0=td_mpp%i_perio … … 424 425 ! 425 426 !> @author J.Paul 426 !> - June, 2013- Initial Version427 !> @date June, 2013 - Initial Version 427 428 !> @date September, 2014 428 429 !> - add boundary index … … 489 490 490 491 IF( td_file%i_perio < 0 .OR. td_file%i_perio > 6 )THEN 491 CALL logger_error("DOM INIT: invalid grid periodicity. "//& 492 & "you should use grid_get_perio to compute it") 492 CALL logger_error("DOM INIT: invalid grid periodicity ("//& 493 & TRIM(fct_str(td_file%i_perio))//& 494 & ") you should use grid_get_perio to compute it") 493 495 ELSE 494 496 dom__init_file%i_perio0=td_file%i_perio … … 548 550 !> 549 551 !> @author J.Paul 550 !> - November, 2013- Subroutine written552 !> @date November, 2013 - Initial version 551 553 ! 552 554 !> @param[inout] td_dom domain structure … … 653 655 !> 654 656 !> @author J.Paul 655 !> - November, 2013- Subroutine written657 !> @date November, 2013 - Initial version 656 658 !> @date September, 2014 657 659 !> - use zero indice to defined cyclic or global domain … … 721 723 !> 722 724 !> @author J.Paul 723 !> - November, 2013- Subroutine written725 !> @date November, 2013 - Initial verison 724 726 ! 725 727 !> @param[inout] td_dom domain strcuture … … 755 757 !> 756 758 !> @author J.Paul 757 !> - November, 2013- Subroutine written759 !> @date November, 2013 - Initial version 758 760 ! 759 761 !> @param[inout] td_dom domain strcuture … … 774 776 !> 775 777 !> @author J.Paul 776 !> - November, 2013- Subroutine written778 !> @date November, 2013 - Initial version 777 779 ! 778 780 !> @param[inout] td_dom domain strcuture … … 806 808 !> 807 809 !> @author J.Paul 808 !> - November, 2013- Subroutine written810 !> @date November, 2013 - Initial version 809 811 ! 810 812 !> @param[inout] td_dom domain strcuture … … 824 826 !> 825 827 !> @author J.Paul 826 !> - November, 2013- Subroutine written828 !> @date November, 2013 - Initial version 827 829 ! 828 830 !> @param[inout] td_dom domain strcuture … … 862 864 !> 863 865 !> @author J.Paul 864 !> - November, 2013- Subroutine written866 !> @date November, 2013 - Initial version 865 867 ! 866 868 !> @param[inout] td_dom domain strcuture … … 912 914 !> 913 915 !> @author J.Paul 914 !> - November, 2013- Subroutine written916 !> @date November, 2013 - Initial version 915 917 ! 916 918 !> @param[inout] td_dom domain strcuture … … 951 953 !> 952 954 !> @author J.Paul 953 !> - April, 2013- Subroutine written955 !> @date April, 2013 - Initial version 954 956 ! 955 957 !> @param[inout] td_dom domain strcuture … … 979 981 !> 980 982 !> @author J.Paul 981 !> - November, 2013- Subroutine written983 !> @date November, 2013 - Initial version 982 984 ! 983 985 !> @param[inout] td_dom domain strcuture … … 1041 1043 !> 1042 1044 !> @author J.Paul 1043 !> - November, 2013- Subroutine written1045 !> @date November, 2013 - Initial version 1044 1046 ! 1045 1047 !> @param[inout] td_dom domain strcuture … … 1082 1084 !> 1083 1085 !> @author J.Paul 1084 !> - November, 2013- Subroutine written1086 !> @date November, 2013 - Initial version 1085 1087 ! 1086 1088 !> @param[inout] td_dom domain strcuture … … 1180 1182 !> 1181 1183 !> @author J.Paul 1182 !> - November, 2013- Subroutine written1184 !> @date November, 2013 - Initial version 1183 1185 ! 1184 1186 !> @param[inout] td_dom domain strcuture … … 1292 1294 !> 1293 1295 !> @author J.Paul 1294 !> @date November, 2013 1296 !> @date November, 2013 - Initial version 1295 1297 !> @date September, 2014 1296 1298 !> - take into account number of ghost cell … … 1433 1435 ! 1434 1436 !> @author J.Paul 1435 !> @date November, 2013 1437 !> @date November, 2013 - Initial version 1436 1438 ! 1437 1439 !> @param[inout] td_dom domain strcuture … … 1476 1478 !> 1477 1479 !> @author J.Paul 1478 !> @date November, 2013 1480 !> @date November, 2013 - Initial version 1479 1481 !> @date September, 2014 1480 1482 !> - take into account boundary for one point size domain … … 1715 1717 ! 1716 1718 !> @author J.Paul 1717 !> @date November, 2013 1719 !> @date November, 2013 - Initial version 1718 1720 ! 1719 1721 !> @param[inout] td_dom domain strcuture -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/extrap.f90
r5037 r6487 19 19 !> defining string character _cn\_varinfo_. By default _dist_weight_.<br/> 20 20 !> Example: 21 !> - cn_varinfo='varname1: dist_weight', 'varname2:min_error'21 !> - cn_varinfo='varname1:ext=dist_weight', 'varname2:ext=min_error' 22 22 !> 23 23 !> to detect point to be extrapolated:<br/> 24 24 !> @code 25 !> il_detect(:,:,:)=extrap_detect(td_var , [td_level], [id_offset,] [id_rho,] [id_ext])25 !> il_detect(:,:,:)=extrap_detect(td_var) 26 26 !> @endcode 27 27 !> - il_detect(:,:,:) is 3D array of point to be extrapolated 28 28 !> - td_var is coarse grid variable to be extrapolated 29 !> - td_level is fine grid array of level (see vgrid_get_level) [optional]30 !> - id_offset is array of offset between fine and coarse grid [optional]31 !> - id_rho is array of refinment factor [optional]32 !> - id_ext is array of number of points to be extrapolated [optional]33 29 !> 34 30 !> to extrapolate variable:<br/> 35 31 !> @code 36 !> CALL extrap_fill_value( td_var, [ td_level], [id_offset], [id_rho], [id_iext], [id_jext], [id_kext], [id_radius], [id_maxiter])32 !> CALL extrap_fill_value( td_var, [id_radius]) 37 33 !> @endcode 38 34 !> - td_var is coarse grid variable to be extrapolated 39 !> - td_level is fine grid array of level (see vgrid_get_level) [optional]40 !> - id_offset is array of offset between fine and coarse grid [optional]41 !> - id_rho is array of refinment factor [optional]42 !> - id_iext is number of points to be extrapolated in i-direction [optional]43 !> - id_jext is number of points to be extrapolated in j-direction [optional]44 !> - id_kext is number of points to be extrapolated in k-direction [optional]45 35 !> - id_radius is radius of the halo used to compute extrapolation [optional] 46 !> - id_maxiter is maximum number of iteration [optional]47 36 !> 48 37 !> to add extraband to the variable (to be extrapolated):<br/> … … 62 51 !> - id_jsize : j-direction size of extra bands [optional] 63 52 !> 64 !> to compute first derivative of 1D array:<br/>65 !> @code66 !> dl_value(:)=extrap_deriv_1D( dd_value(:), dd_fill, [ld_discont] )67 !> @endcode68 !> - dd_value is 1D array of variable69 !> - dd_fill is FillValue of variable70 !> - ld_discont is logical to take into account longitudinal East-West discontinuity [optional]71 !>72 !> to compute first derivative of 2D array:<br/>73 !> @code74 !> dl_value(:,:)=extrap_deriv_2D( dd_value(:,:), dd_fill, cd_dim, [ld_discont] )75 !> @endcode76 !> - dd_value is 2D array of variable77 !> - dd_fill is FillValue of variable78 !> - cd_dim is character to compute derivative on first (I) or second (J) dimension79 !> - ld_discont is logical to take into account longitudinal East-West discontinuity [optional]80 !>81 !> to compute first derivative of 3D array:<br/>82 !> @code83 !> dl_value(:,:,:)=extrap_deriv_3D( dd_value(:,:,:), dd_fill, cd_dim, [ld_discont] )84 !> @endcode85 !> - dd_value is 3D array of variable86 !> - dd_fill is FillValue of variable87 !> - cd_dim is character to compute derivative on first (I), second (J), or third (K) dimension88 !> - ld_discont is logical to take into account longitudinal East-West discontinuity [optional]89 !>90 53 !> @warning _FillValue must not be zero (use var_chg_FillValue()) 91 54 !> … … 93 56 !> J.Paul 94 57 ! REVISION HISTORY: 95 !> @date Nov , 2013 - Initial Version58 !> @date November, 2013 - Initial Version 96 59 !> @date September, 2014 97 60 !> - add header 61 !> @date June, 2015 62 !> - extrapolate all land points (_FillValue) 63 !> - move deriv function to math module 64 !> @date July, 2015 65 !> - compute extrapolation from north west to south east, 66 !> and from south east to north west 98 67 !> 99 68 !> @todo 100 69 !> - create module for each extrapolation method 70 !> - smooth extrapolated points 101 71 !> 102 72 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 110 80 USE date ! date manager 111 81 USE logger ! log file manager 82 USE math ! mathematical function 112 83 USE att ! attribute manager 113 84 USE dim ! dimension manager … … 118 89 119 90 ! type and variable 120 PRIVATE :: im_maxiter !< default maximum number of iteration121 91 PRIVATE :: im_minext !< default minumum number of point to extrapolate 122 92 PRIVATE :: im_mincubic !< default minumum number of point to extrapolate for cubic interpolation … … 127 97 PUBLIC :: extrap_add_extrabands !< add extraband to the variable (to be extrapolated) 128 98 PUBLIC :: extrap_del_extrabands !< delete extraband of the variable 129 PUBLIC :: extrap_deriv_1D !< compute first derivative of 1D array130 PUBLIC :: extrap_deriv_2D !< compute first derivative of 2D array131 PUBLIC :: extrap_deriv_3D !< compute first derivative of 3D array132 99 133 100 PRIVATE :: extrap__detect_wrapper ! detected point to be extrapolated wrapper … … 141 108 PRIVATE :: extrap__3D_dist_weight_fill ! 142 109 143 INTEGER(i4), PARAMETER :: im_maxiter = 10 !< default maximum number of iteration144 110 INTEGER(i4), PARAMETER :: im_minext = 2 !< default minumum number of point to extrapolate 145 111 INTEGER(i4), PARAMETER :: im_mincubic= 4 !< default minumum number of point to extrapolate for cubic interpolation … … 171 137 !> 172 138 !> @author J.Paul 173 !> - November, 2013- Initial Version 139 !> @date November, 2013 - Initial Version 140 !> @date June, 2015 141 !> - do not use level to select points to be extrapolated 174 142 ! 175 143 !> @param[in] td_var0 coarse grid variable to extrapolate 176 !> @param[in] td_level1 fine grid array of level177 !> @param[in] id_offset array of offset between fine and coarse grid178 !> @param[in] id_rho array of refinment factor179 !> @param[in] id_ext array of number of points to be extrapolated180 144 !> @return array of point to be extrapolated 181 145 !------------------------------------------------------------------- 182 FUNCTION extrap__detect( td_var0, td_level1, & 183 & id_offset, id_rho, id_ext ) 146 FUNCTION extrap__detect( td_var0 ) 184 147 IMPLICIT NONE 185 148 ! Argument 186 149 TYPE(TVAR) , INTENT(IN ) :: td_var0 187 TYPE(TVAR) , DIMENSION(:) , INTENT(IN ), OPTIONAL :: td_level1188 INTEGER(i4), DIMENSION(:,:), INTENT(IN ), OPTIONAL :: id_offset189 INTEGER(i4), DIMENSION(:) , INTENT(IN ), OPTIONAL :: id_rho190 INTEGER(i4), DIMENSION(:) , INTENT(IN ), OPTIONAL :: id_ext191 150 192 151 ! function … … 196 155 197 156 ! local variable 198 CHARACTER(LEN=lc) :: cl_level199 200 INTEGER(i4) :: il_ind201 INTEGER(i4) , DIMENSION(:,:,:), ALLOCATABLE :: il_detect202 INTEGER(i4) , DIMENSION(:,:,:), ALLOCATABLE :: il_tmp203 INTEGER(i4) , DIMENSION(:,:) , ALLOCATABLE :: il_offset204 INTEGER(i4) , DIMENSION(:,:) , ALLOCATABLE :: il_level1205 INTEGER(i4) , DIMENSION(:,:) , ALLOCATABLE :: il_level1_G0206 INTEGER(i4) , DIMENSION(:,:) , ALLOCATABLE :: il_extra207 INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_ext208 INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_rho209 INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_dim0210 211 TYPE(TVAR) :: tl_var1212 213 157 ! loop indices 214 158 INTEGER(i4) :: ji0 215 159 INTEGER(i4) :: jj0 216 160 INTEGER(i4) :: jk0 217 INTEGER(i4) :: ji1218 INTEGER(i4) :: jj1219 INTEGER(i4) :: ji1m220 INTEGER(i4) :: jj1m221 INTEGER(i4) :: ji1p222 INTEGER(i4) :: jj1p223 161 !---------------------------------------------------------------- 224 162 225 ! init 226 extrap__detect(:,:,:)=0 227 228 ALLOCATE( il_dim0(3) ) 229 il_dim0(:)=td_var0%t_dim(1:3)%i_len 230 231 ! optional argument 232 ALLOCATE( il_rho(ip_maxdim) ) 233 il_rho(:)=1 234 IF( PRESENT(id_rho) ) il_rho(1:SIZE(id_rho(:)))=id_rho(:) 235 236 ALLOCATE( il_offset(ip_maxdim,2) ) 237 il_offset(:,:)=0 238 IF( PRESENT(id_offset) )THEN 239 il_offset(1:SIZE(id_offset(:,:),DIM=1),& 240 & 1:SIZE(id_offset(:,:),DIM=2) )= id_offset(:,:) 241 ELSE 242 il_offset(jp_I,:)=FLOOR(REAL(il_rho(jp_I)-1,dp)*0.5) 243 il_offset(jp_J,:)=FLOOR(REAL(il_rho(jp_J)-1,dp)*0.5) 244 ENDIF 245 246 ALLOCATE( il_ext(ip_maxdim) ) 247 il_ext(:)=im_minext 248 IF( PRESENT(id_ext) ) il_ext(1:SIZE(id_ext(:)))=id_ext(:) 249 250 ALLOCATE( il_detect(il_dim0(1),& 251 & il_dim0(2),& 252 & il_dim0(3)) ) 253 il_detect(:,:,:)=0 254 255 ! select point already inform 256 DO jk0=1,td_var0%t_dim(3)%i_len 257 DO jj0=1,td_var0%t_dim(2)%i_len 258 DO ji0=1,td_var0%t_dim(1)%i_len 259 IF( td_var0%d_value(ji0,jj0,jk0,1) /= td_var0%d_fill ) il_detect(ji0,jj0,jk0)=1 260 ENDDO 261 ENDDO 262 ENDDO 263 264 IF( PRESENT(td_level1) )THEN 265 SELECT CASE(TRIM(td_var0%c_point)) 266 CASE DEFAULT !'T' 267 cl_level='tlevel' 268 CASE('U') 269 cl_level='ulevel' 270 CASE('V') 271 cl_level='vlevel' 272 CASE('F') 273 cl_level='flevel' 274 END SELECT 275 276 il_ind=var_get_index(td_level1(:),TRIM(cl_level)) 277 IF( il_ind == 0 )THEN 278 CALL logger_error("EXTRAP DETECT: can not compute point to be "//& 279 & "extrapolated for variable "//TRIM(td_var0%c_name)//& 280 & ". can not find "//& 281 & "level for variable point "//TRIM(TRIM(td_var0%c_point))) 282 ELSE 283 tl_var1=var_copy(td_level1(il_ind)) 284 285 ALLOCATE( il_level1_G0( il_dim0(1), il_dim0(2)) ) 286 IF( ALL(tl_var1%t_dim(1:2)%i_len == il_dim0(1:2)) )THEN 287 288 ! variable to be extrapolated use same resolution than level 289 il_level1_G0(:,:)=INT(tl_var1%d_value(:,:,1,1),i4) 290 291 ELSE 292 ! variable to be extrapolated do not use same resolution than level 293 ALLOCATE( il_level1(tl_var1%t_dim(1)%i_len, & 294 & tl_var1%t_dim(2)%i_len) ) 295 ! match fine grid vertical level with coarse grid 296 il_level1(:,:)=INT(tl_var1%d_value(:,:,1,1),i4)/il_rho(jp_K) 297 298 ALLOCATE( il_extra(ip_maxdim,2) ) 299 ! coarsening fine grid level 300 il_extra(jp_I,1)=CEILING(REAL(il_rho(jp_I)-1,dp)*0.5_dp) 301 il_extra(jp_I,2)=FLOOR(REAL(il_rho(jp_I)-1,dp)*0.5_dp) 302 303 il_extra(jp_J,1)=CEILING(REAL(il_rho(jp_J)-1,dp)*0.5_dp) 304 il_extra(jp_J,2)=FLOOR(REAL(il_rho(jp_J)-1,dp)*0.5_dp) 305 306 DO jj0=1,td_var0%t_dim(2)%i_len 307 308 jj1=(jj0-1)*il_rho(jp_J)+1-il_offset(jp_J,1) 309 310 jj1m=MAX( jj1-il_extra(jp_J,1), 1 ) 311 jj1p=MIN( jj1+il_extra(jp_J,2), & 312 & tl_var1%t_dim(2)%i_len-il_offset(jp_J,2) ) 313 314 DO ji0=1,td_var0%t_dim(1)%i_len 315 316 ji1=(ji0-1)*il_rho(jp_I)+1-id_offset(jp_I,1) 317 318 ji1m=MAX( ji1-il_extra(jp_I,1), 1 ) 319 ji1p=MIN( ji1+il_extra(jp_I,2), & 320 & tl_var1%t_dim(1)%i_len-id_offset(jp_I,2) ) 321 322 il_level1_G0(ji0,jj0)=MAXVAL(il_level1(ji1m:ji1p,jj1m:jj1p)) 323 324 ENDDO 325 ENDDO 326 327 ! clean 328 DEALLOCATE( il_extra ) 329 DEALLOCATE( il_level1 ) 330 331 ENDIF 332 333 ! look for sea point 334 DO jk0=1,td_var0%t_dim(3)%i_len 335 WHERE( il_level1_G0(:,:) >= jk0) 336 il_detect(:,:,jk0)=1 337 END WHERE 338 ENDDO 339 340 ! clean 341 DEALLOCATE( il_level1_G0 ) 342 CALL var_clean(tl_var1) 343 344 ENDIF 345 ENDIF 346 347 ! clean 348 DEALLOCATE( il_offset ) 349 350 ALLOCATE( il_tmp(il_dim0(1),& 351 & il_dim0(2),& 352 & il_dim0(3)) ) 353 il_tmp(:,:,:)=il_detect(:,:,:) 354 ! select extra point depending on interpolation method 355 ! compute point near grid point already inform 356 DO jk0=1,il_dim0(3) 357 DO jj0=1,il_dim0(2) 358 DO ji0=1,il_dim0(1) 359 360 IF( il_tmp(ji0,jj0,jk0) == 1 )THEN 361 il_detect( & 362 & MAX(1,ji0-il_ext(jp_I)):MIN(ji0+il_ext(jp_I),il_dim0(1)),& 363 & MAX(1,jj0-il_ext(jp_J)):MIN(jj0+il_ext(jp_J),il_dim0(2)),& 364 & MAX(1,jk0-il_ext(jp_K)):MIN(jk0+il_ext(jp_K),il_dim0(3)) & 365 & ) = 1 366 ENDIF 367 368 ENDDO 369 ENDDO 370 ENDDO 371 372 ! clean 373 DEALLOCATE( il_tmp ) 163 ! force to extrapolated all points 164 extrap__detect(:,:,:)=1 374 165 375 166 ! do not compute grid point already inform … … 377 168 DO jj0=1,td_var0%t_dim(2)%i_len 378 169 DO ji0=1,td_var0%t_dim(1)%i_len 379 IF( td_var0%d_value(ji0,jj0,jk0,1) /= td_var0%d_fill ) il_detect(ji0,jj0,jk0)=0 170 IF( td_var0%d_value(ji0,jj0,jk0,1) /= td_var0%d_fill )THEN 171 extrap__detect(ji0,jj0,jk0)=0 172 ENDIF 380 173 ENDDO 381 174 ENDDO 382 175 ENDDO 383 384 ! save result385 extrap__detect(:,:,:)=il_detect(:,:,:)386 387 ! clean388 DEALLOCATE( il_dim0 )389 DEALLOCATE( il_ext )390 DEALLOCATE( il_detect )391 DEALLOCATE( il_rho )392 176 393 177 END FUNCTION extrap__detect … … 398 182 !> 399 183 !> @author J.Paul 400 !> - November, 2013- Initial Version 184 !> @date November, 2013 - Initial Version 185 !> @date June, 2015 186 !> - select all land points for extrapolation 401 187 !> 402 188 !> @param[in] td_var coarse grid variable to extrapolate 403 !> @param[in] td_level fine grid array of level404 !> @param[in] id_offset array of offset between fine and coarse grid405 !> @param[in] id_rho array of refinment factor406 !> @param[in] id_ext array of number of points to be extrapolated407 189 !> @return 3D array of point to be extrapolated 408 190 !------------------------------------------------------------------- 409 FUNCTION extrap__detect_wrapper( td_var, td_level, & 410 & id_offset, id_rho, id_ext ) 191 FUNCTION extrap__detect_wrapper( td_var ) 411 192 412 193 IMPLICIT NONE 413 194 ! Argument 414 195 TYPE(TVAR) , INTENT(IN ) :: td_var 415 TYPE(TVAR) , DIMENSION(:) , INTENT(IN ), OPTIONAL :: td_level416 INTEGER(i4), DIMENSION(:,:), INTENT(IN ), OPTIONAL :: id_offset417 INTEGER(i4), DIMENSION(:) , INTENT(IN ), OPTIONAL :: id_rho418 INTEGER(i4), DIMENSION(:) , INTENT(IN ), OPTIONAL :: id_ext419 196 420 197 ! function … … 439 216 & " for variable "//TRIM(td_var%c_name) ) 440 217 441 extrap__detect_wrapper(:,:,:)=extrap__detect( td_var, td_level, & 442 & id_offset, & 443 & id_rho, & 444 & id_ext ) 218 extrap__detect_wrapper(:,:,:)=extrap__detect( td_var ) 445 219 446 220 ELSE IF( ALL(td_var%t_dim(1:2)%l_use) )THEN … … 450 224 & " for variable "//TRIM(td_var%c_name) ) 451 225 452 extrap__detect_wrapper(:,:,1:1)=extrap__detect( td_var , td_level,& 453 & id_offset, & 454 & id_rho, & 455 & id_ext ) 226 extrap__detect_wrapper(:,:,1:1)=extrap__detect( td_var ) 456 227 457 228 ELSE IF( td_var%t_dim(3)%l_use )THEN … … 461 232 & " for variable "//TRIM(td_var%c_name) ) 462 233 463 extrap__detect_wrapper(1:1,1:1,:)=extrap__detect( td_var , td_level, & 464 & id_offset, & 465 & id_rho, & 466 & id_ext ) 234 extrap__detect_wrapper(1:1,1:1,:)=extrap__detect( td_var ) 467 235 468 236 ENDIF … … 489 257 !> 490 258 !> @author J.Paul 491 !> - Nov, 2013- Initial Version 259 !> @date November, 2013 - Initial Version 260 !> @date June, 2015 261 !> - select all land points for extrapolation 492 262 ! 493 263 !> @param[inout] td_var variable structure 494 !> @param[in] td_level fine grid array of level495 !> @param[in] id_offset array of offset between fine and coarse grid496 !> @param[in] id_rho array of refinment factor497 !> @param[in] id_iext number of points to be extrapolated in i-direction498 !> @param[in] id_jext number of points to be extrapolated in j-direction499 !> @param[in] id_kext number of points to be extrapolated in k-direction500 264 !> @param[in] id_radius radius of the halo used to compute extrapolation 501 !> @param[in] id_maxiter maximum number of iteration 502 !------------------------------------------------------------------- 503 SUBROUTINE extrap__fill_value_wrapper( td_var, td_level, & 504 & id_offset, & 505 & id_rho, & 506 & id_iext, id_jext, id_kext, & 507 & id_radius, id_maxiter ) 265 !------------------------------------------------------------------- 266 SUBROUTINE extrap__fill_value_wrapper( td_var, & 267 & id_radius ) 508 268 IMPLICIT NONE 509 269 ! Argument 510 270 TYPE(TVAR) , INTENT(INOUT) :: td_var 511 TYPE(TVAR) , DIMENSION(:) , INTENT(IN ), OPTIONAL :: td_level512 INTEGER(i4), DIMENSION(:,:), INTENT(IN ), OPTIONAL :: id_offset513 INTEGER(i4), DIMENSION(:) , INTENT(IN ), OPTIONAL :: id_rho514 INTEGER(i4), INTENT(IN ), OPTIONAL :: id_iext515 INTEGER(i4), INTENT(IN ), OPTIONAL :: id_jext516 INTEGER(i4), INTENT(IN ), OPTIONAL :: id_kext517 271 INTEGER(i4), INTENT(IN ), OPTIONAL :: id_radius 518 INTEGER(i4), INTENT(IN ), OPTIONAL :: id_maxiter519 272 520 273 ! local variable 521 INTEGER(i4) :: il_iext522 INTEGER(i4) :: il_jext523 INTEGER(i4) :: il_kext524 274 INTEGER(i4) :: il_radius 525 INTEGER(i4) :: il_maxiter526 275 527 276 CHARACTER(LEN=lc) :: cl_method … … 544 293 END SELECT 545 294 546 il_iext=im_minext 547 IF( PRESENT(id_iext) ) il_iext=id_iext 548 il_jext=im_minext 549 IF( PRESENT(id_jext) ) il_jext=id_jext 550 il_kext=0 551 IF( PRESENT(id_kext) ) il_kext=id_kext 552 553 IF( TRIM(td_var%c_interp(1)) == 'cubic')THEN 554 IF( il_iext > 0 .AND. il_iext < im_mincubic ) il_iext=im_mincubic 555 IF( il_jext > 0 .AND. il_jext < im_mincubic ) il_jext=im_mincubic 295 ! number of point use to compute box 296 il_radius=1 297 IF( PRESENT(id_radius) ) il_radius=id_radius 298 IF( il_radius < 0 )THEN 299 CALL logger_error("EXTRAP FILL VALUE: invalid "//& 300 & " radius of the box used to compute extrapolation "//& 301 & "("//TRIM(fct_str(il_radius))//")") 556 302 ENDIF 557 303 558 IF( il_iext < 0 )THEN 559 CALL logger_error("EXTRAP FILL VALUE: invalid "//& 560 & " number of points to be extrapolated in i-direction "//& 561 & "("//TRIM(fct_str(il_iext))//")") 562 ENDIF 563 564 IF( il_jext < 0 )THEN 565 CALL logger_error("EXTRAP FILL VALUE: invalid "//& 566 & " number of points to be extrapolated in j-direction "//& 567 & "("//TRIM(fct_str(il_jext))//")") 568 ENDIF 569 570 IF( il_kext < 0 )THEN 571 CALL logger_error("EXTRAP FILL VALUE: invalid "//& 572 & " number of points to be extrapolated in k-direction "//& 573 & "("//TRIM(fct_str(il_kext))//")") 574 ENDIF 575 576 IF( (il_iext /= 0 .AND. td_var%t_dim(1)%l_use) .OR. & 577 & (il_jext /= 0 .AND. td_var%t_dim(2)%l_use) .OR. & 578 & (il_kext /= 0 .AND. td_var%t_dim(3)%l_use) )THEN 579 580 ! number of point use to compute box 581 il_radius=1 582 IF( PRESENT(id_radius) ) il_radius=id_radius 583 IF( il_radius < 0 )THEN 584 CALL logger_error("EXTRAP FILL VALUE: invalid "//& 585 & " radius of the box used to compute extrapolation "//& 586 & "("//TRIM(fct_str(il_radius))//")") 587 ENDIF 588 589 ! maximum number of iteration 590 il_maxiter=im_maxiter 591 IF( PRESENT(id_maxiter) ) il_maxiter=id_maxiter 592 IF( il_maxiter < 0 )THEN 593 CALL logger_error("EXTRAP FILL VALUE: invalid "//& 594 & " maximum nuber of iteration "//& 595 & "("//TRIM(fct_str(il_maxiter))//")") 596 ENDIF 597 598 CALL logger_info("EXTRAP FILL: extrapolate "//TRIM(td_var%c_name)//& 599 & " using "//TRIM(cl_method)//" method." ) 600 601 CALL extrap__fill_value( td_var, cl_method, & 602 & il_iext, il_jext, il_kext, & 603 & il_radius, il_maxiter, & 604 & td_level, & 605 & id_offset, id_rho ) 606 607 ENDIF 304 CALL logger_info("EXTRAP FILL: extrapolate "//TRIM(td_var%c_name)//& 305 & " using "//TRIM(cl_method)//" method." ) 306 307 CALL extrap__fill_value( td_var, cl_method, & 308 & il_radius ) 608 309 609 310 ENDIF … … 621 322 !> 622 323 !> @author J.Paul 623 !> - November, 2013- Initial Version 324 !> @date November, 2013 - Initial Version 325 !> @date June, 2015 326 !> - select all land points for extrapolation 624 327 ! 625 328 !> @param[inout] td_var variable structure 626 329 !> @param[in] cd_method extrapolation method 627 !> @param[in] id_iext number of points to be extrapolated in i-direction628 !> @param[in] id_jext number of points to be extrapolated in j-direction629 !> @param[in] id_kext number of points to be extrapolated in k-direction630 330 !> @param[in] id_radius radius of the halo used to compute extrapolation 631 !> @param[in] id_maxiter maximum number of iteration632 !> @param[in] td_level fine grid array of level633 !> @param[in] id_offset array of offset between fine and coarse grid634 !> @param[in] id_rho array of refinment factor635 331 !------------------------------------------------------------------- 636 332 SUBROUTINE extrap__fill_value( td_var, cd_method, & 637 & id_iext, id_jext, id_kext, & 638 & id_radius, id_maxiter, & 639 & td_level, & 640 & id_offset, & 641 & id_rho ) 333 & id_radius ) 642 334 IMPLICIT NONE 643 335 ! Argument 644 336 TYPE(TVAR) , INTENT(INOUT) :: td_var 645 337 CHARACTER(LEN=*), INTENT(IN ) :: cd_method 646 INTEGER(i4) , INTENT(IN ) :: id_iext647 INTEGER(i4) , INTENT(IN ) :: id_jext648 INTEGER(i4) , INTENT(IN ) :: id_kext649 338 INTEGER(i4) , INTENT(IN ) :: id_radius 650 INTEGER(i4) , INTENT(IN ) :: id_maxiter651 TYPE(TVAR) , DIMENSION(:) , INTENT(IN ), OPTIONAL :: td_level652 INTEGER(i4) , DIMENSION(:,:), INTENT(IN ), OPTIONAL :: id_offset653 INTEGER(i4) , DIMENSION(:) , INTENT(IN ), OPTIONAL :: id_rho654 339 655 340 ! local variable … … 668 353 & td_var%t_dim(3)%i_len) ) 669 354 670 il_detect(:,:,:) = extrap_detect( td_var, td_level, & 671 & id_offset, & 672 & id_rho, & 673 & id_ext=(/id_iext, id_jext, id_kext/) ) 355 il_detect(:,:,:) = extrap_detect( td_var ) 356 674 357 !2- add attribute to variable 675 358 cl_extrap=fct_concat(td_var%c_extrap(:)) … … 679 362 CALL att_clean(tl_att) 680 363 681 CALL logger_info(" EXTRAP FILL: "//& 682 & TRIM(fct_str(SUM(il_detect(:,:,:))))//& 683 & " point(s) to extrapolate " ) 684 685 !3- extrapolate 686 CALL extrap__3D(td_var%d_value(:,:,:,:), td_var%d_fill, & 687 & il_detect(:,:,:), & 688 & cd_method, id_radius, id_maxiter ) 364 IF( ALL(il_detect(:,:,:)==1) )THEN 365 CALL logger_warn(" EXTRAP FILL: "//& 366 & " can not extrapolate "//TRIM(td_var%c_name)//& 367 & ". no value inform." ) 368 ELSE 369 CALL logger_info(" EXTRAP FILL: "//& 370 & TRIM(fct_str(SUM(il_detect(:,:,:))))//& 371 & " point(s) to extrapolate " ) 372 373 CALL logger_info(" EXTRAP FILL: method "//& 374 & TRIM(cd_method) ) 375 376 !3- extrapolate 377 CALL extrap__3D(td_var%d_value(:,:,:,:), td_var%d_fill, & 378 & il_detect(:,:,:), & 379 & cd_method, id_radius ) 380 ENDIF 689 381 690 382 DEALLOCATE(il_detect) … … 705 397 !> 706 398 !> @author J.Paul 707 !> - Nov, 2013- Initial Version 399 !> @date November, 2013 - Initial Version 400 !> @date July, 2015 401 !> - compute coef indices to be used 402 !> - bug fix: force coef indice to 1, for dimension lenth equal to 1 708 403 ! 709 404 !> @param[inout] dd_value 3D array of variable to be extrapolated … … 714 409 !------------------------------------------------------------------- 715 410 SUBROUTINE extrap__3D( dd_value, dd_fill, id_detect,& 716 & cd_method, id_radius , id_maxiter)411 & cd_method, id_radius ) 717 412 IMPLICIT NONE 718 413 ! Argument 719 414 REAL(dp) , DIMENSION(:,:,:,:), INTENT(INOUT) :: dd_value 720 REAL(dp) , INTENT(IN ) :: dd_fill 721 INTEGER(i4), DIMENSION(:,:,:), INTENT(INOUT) :: id_detect 722 CHARACTER(LEN=*), INTENT(IN ) :: cd_method 723 INTEGER(i4), INTENT(IN ) :: id_radius 724 INTEGER(i4), INTENT(IN ) :: id_maxiter 415 REAL(dp) , INTENT(IN ) :: dd_fill 416 INTEGER(i4), DIMENSION(:,:,:) , INTENT(INOUT) :: id_detect 417 CHARACTER(LEN=*), INTENT(IN ) :: cd_method 418 INTEGER(i4), INTENT(IN ) :: id_radius 725 419 726 420 ! local variable 727 INTEGER(i4) :: il_imin 728 INTEGER(i4) :: il_imax 729 INTEGER(i4) :: il_jmin 730 INTEGER(i4) :: il_jmax 731 INTEGER(i4) :: il_kmin 732 INTEGER(i4) :: il_kmax 733 INTEGER(i4) :: il_iter 734 INTEGER(i4) :: il_radius 735 736 INTEGER(i4), DIMENSION(4) :: il_shape 737 INTEGER(i4), DIMENSION(3) :: il_dim 421 INTEGER(i4) :: il_imin 422 INTEGER(i4) :: il_imax 423 INTEGER(i4) :: il_jmin 424 INTEGER(i4) :: il_jmax 425 INTEGER(i4) :: il_kmin 426 INTEGER(i4) :: il_kmax 427 INTEGER(i4) :: il_iter 428 INTEGER(i4) :: il_radius 429 INTEGER(i4) :: il_i1 430 INTEGER(i4) :: il_i2 431 INTEGER(i4) :: il_j1 432 INTEGER(i4) :: il_j2 433 INTEGER(i4) :: il_k1 434 INTEGER(i4) :: il_k2 435 436 INTEGER(i4), DIMENSION(4) :: il_shape 437 INTEGER(i4), DIMENSION(3) :: il_dim 738 438 739 439 INTEGER(i4), DIMENSION(:,:,:), ALLOCATABLE :: il_detect … … 743 443 REAL(dp) , DIMENSION(:,:,:), ALLOCATABLE :: dl_dfdz 744 444 REAL(dp) , DIMENSION(:,:,:), ALLOCATABLE :: dl_coef 445 446 LOGICAL :: ll_iter 745 447 746 448 ! loop indices … … 765 467 DO WHILE( ANY(il_detect(:,:,:)==1) ) 766 468 ! change extend value to minimize number of iteration 767 il_radius=id_radius+(il_iter/id_maxiter) 469 il_radius=id_radius+(il_iter-1) 470 ll_iter=.TRUE. 768 471 769 472 ALLOCATE( dl_dfdx(il_shape(1), il_shape(2), il_shape(3)) ) … … 774 477 dl_dfdx(:,:,:)=dd_fill 775 478 IF( il_shape(1) > 1 )THEN 776 dl_dfdx(:,:,:)=extrap_deriv_3D( dd_value(:,:,:,jl), dd_fill, 'I' ) 479 dl_dfdx(:,:,:)=math_deriv_3D( dd_value(:,:,:,jl), & 480 & dd_fill, 'I' ) 777 481 ENDIF 778 482 … … 780 484 dl_dfdy(:,:,:)=dd_fill 781 485 IF( il_shape(2) > 1 )THEN 782 dl_dfdy(:,:,:)=extrap_deriv_3D( dd_value(:,:,:,jl), dd_fill, 'J' ) 486 dl_dfdy(:,:,:)=math_deriv_3D( dd_value(:,:,:,jl), & 487 & dd_fill, 'J' ) 783 488 ENDIF 784 489 … … 786 491 dl_dfdz(:,:,:)=dd_fill 787 492 IF( il_shape(3) > 1 )THEN 788 dl_dfdz(:,:,:)=extrap_deriv_3D( dd_value(:,:,:,jl), dd_fill, 'K' ) 493 dl_dfdz(:,:,:)=math_deriv_3D( dd_value(:,:,:,jl), & 494 & dd_fill, 'K' ) 789 495 ENDIF 790 496 … … 804 510 805 511 DO jk=1,il_shape(3) 512 ! from North West(1,1) to South East(il_shape(1),il_shape(2)) 806 513 IF( ALL(il_detect(:,:,jk) == 0) ) CYCLE 807 514 DO jj=1,il_shape(2) … … 813 520 il_imin=MAX(ji-il_radius,1) 814 521 il_imax=MIN(ji+il_radius,il_shape(1)) 522 ! coef indices to be used 523 il_i1 = il_radius-(ji-il_imin)+1 524 il_i2 = il_radius+(il_imax-ji)+1 815 525 IF( il_dim(1) == 1 )THEN 816 526 il_imin=ji 817 527 il_imax=ji 818 ENDIF 528 ! coef indices to be used 529 il_i1 = 1 530 il_i2 = 1 531 ENDIF 532 819 533 820 534 il_jmin=MAX(jj-il_radius,1) 821 535 il_jmax=MIN(jj+il_radius,il_shape(2)) 536 ! coef indices to be used 537 il_j1 = il_radius-(jj-il_jmin)+1 538 il_j2 = il_radius+(il_jmax-jj)+1 822 539 IF( il_dim(2) == 1 )THEN 823 540 il_jmin=jj 824 541 il_jmax=jj 542 ! coef indices to be used 543 il_j1 = 1 544 il_j2 = 1 825 545 ENDIF 826 546 827 547 il_kmin=MAX(jk-il_radius,1) 828 548 il_kmax=MIN(jk+il_radius,il_shape(3)) 549 ! coef indices to be used 550 il_k1 = il_radius-(jk-il_kmin)+1 551 il_k2 = il_radius+(il_kmax-jk)+1 829 552 IF( il_dim(3) == 1 )THEN 830 553 il_kmin=jk 831 554 il_kmax=jk 555 ! coef indices to be used 556 il_k1 = 1 557 il_k2 = 1 832 558 ENDIF 833 559 … … 845 571 & il_jmin:il_jmax, & 846 572 & il_kmin:il_kmax ), & 847 & dl_coef(:,:,:) ) 573 & dl_coef(il_i1:il_i2, & 574 & il_j1:il_j2, & 575 & il_k1:il_k2) ) 848 576 849 577 IF( dd_value(ji,jj,jk,jl) /= dd_fill )THEN 850 578 il_detect(ji,jj,jk)= 0 579 ll_iter=.FALSE. 580 ENDIF 581 582 ENDIF 583 584 ENDDO 585 ENDDO 586 ! from South East(il_shape(1),il_shape(2)) to North West(1,1) 587 IF( ALL(il_detect(:,:,jk) == 0) ) CYCLE 588 DO jj=il_shape(2),1,-1 589 IF( ALL(il_detect(:,jj,jk) == 0) ) CYCLE 590 DO ji=il_shape(1),1,-1 591 592 IF( il_detect(ji,jj,jk) == 1 )THEN 593 594 il_imin=MAX(ji-il_radius,1) 595 il_imax=MIN(ji+il_radius,il_shape(1)) 596 ! coef indices to be used 597 il_i1 = il_radius-(ji-il_imin)+1 598 il_i2 = il_radius+(il_imax-ji)+1 599 IF( il_dim(1) == 1 )THEN 600 il_imin=ji 601 il_imax=ji 602 ! coef indices to be used 603 il_i1 = 1 604 il_i2 = 1 605 ENDIF 606 607 608 il_jmin=MAX(jj-il_radius,1) 609 il_jmax=MIN(jj+il_radius,il_shape(2)) 610 ! coef indices to be used 611 il_j1 = il_radius-(jj-il_jmin)+1 612 il_j2 = il_radius+(il_jmax-jj)+1 613 IF( il_dim(2) == 1 )THEN 614 il_jmin=jj 615 il_jmax=jj 616 ! coef indices to be used 617 il_j1 = 1 618 il_j2 = 1 619 ENDIF 620 621 il_kmin=MAX(jk-il_radius,1) 622 il_kmax=MIN(jk+il_radius,il_shape(3)) 623 ! coef indices to be used 624 il_k1 = il_radius-(jk-il_kmin)+1 625 il_k2 = il_radius+(il_kmax-jk)+1 626 IF( il_dim(3) == 1 )THEN 627 il_kmin=jk 628 il_kmax=jk 629 ! coef indices to be used 630 il_k1 = 1 631 il_k2 = 1 632 ENDIF 633 634 dd_value(ji,jj,jk,jl)=extrap__3D_min_error_fill( & 635 & dd_value( il_imin:il_imax, & 636 & il_jmin:il_jmax, & 637 & il_kmin:il_kmax,jl ), dd_fill, il_radius, & 638 & dl_dfdx( il_imin:il_imax, & 639 & il_jmin:il_jmax, & 640 & il_kmin:il_kmax ), & 641 & dl_dfdy( il_imin:il_imax, & 642 & il_jmin:il_jmax, & 643 & il_kmin:il_kmax ), & 644 & dl_dfdz( il_imin:il_imax, & 645 & il_jmin:il_jmax, & 646 & il_kmin:il_kmax ), & 647 & dl_coef(il_i1:il_i2, & 648 & il_j1:il_j2, & 649 & il_k1:il_k2) ) 650 651 IF( dd_value(ji,jj,jk,jl) /= dd_fill )THEN 652 il_detect(ji,jj,jk)= 0 653 ll_iter=.FALSE. 851 654 ENDIF 852 655 … … 862 665 DEALLOCATE( dl_coef ) 863 666 864 il_iter=il_iter+1667 IF( ll_iter ) il_iter=il_iter+1 865 668 ENDDO 866 669 ENDDO … … 875 678 DO WHILE( ANY(il_detect(:,:,:)==1) ) 876 679 ! change extend value to minimize number of iteration 877 il_radius=id_radius+(il_iter/id_maxiter) 680 il_radius=id_radius+(il_iter-1) 681 ll_iter=.TRUE. 878 682 879 683 il_dim(1)=2*il_radius+1 … … 886 690 ALLOCATE( dl_coef(il_dim(1), il_dim(2), il_dim(3)) ) 887 691 888 dl_coef(:,:,:)=extrap__3D_dist_weight_coef(dd_value(1:il_dim(1), 889 & 1:il_dim(2), 890 & 1:il_dim(3), 692 dl_coef(:,:,:)=extrap__3D_dist_weight_coef(dd_value(1:il_dim(1),& 693 & 1:il_dim(2),& 694 & 1:il_dim(3),& 891 695 & jl ) ) 892 696 893 697 DO jk=1,il_shape(3) 698 ! from North West(1,1) to South East(il_shape(1),il_shape(2)) 894 699 IF( ALL(il_detect(:,:,jk) == 0) ) CYCLE 895 700 DO jj=1,il_shape(2) … … 901 706 il_imin=MAX(ji-il_radius,1) 902 707 il_imax=MIN(ji+il_radius,il_shape(1)) 708 ! coef indices to be used 709 il_i1 = il_radius-(ji-il_imin)+1 710 il_i2 = il_radius+(il_imax-ji)+1 903 711 IF( il_dim(1) == 1 )THEN 904 712 il_imin=ji 905 713 il_imax=ji 714 ! coef indices to be used 715 il_i1 = 1 716 il_i2 = 1 906 717 ENDIF 907 718 908 719 il_jmin=MAX(jj-il_radius,1) 909 720 il_jmax=MIN(jj+il_radius,il_shape(2)) 721 ! coef indices to be used 722 il_j1 = il_radius-(jj-il_jmin)+1 723 il_j2 = il_radius+(il_jmax-jj)+1 910 724 IF( il_dim(2) == 1 )THEN 911 725 il_jmin=jj 912 726 il_jmax=jj 727 ! coef indices to be used 728 il_j1 = 1 729 il_j2 = 1 913 730 ENDIF 914 731 915 732 il_kmin=MAX(jk-il_radius,1) 916 733 il_kmax=MIN(jk+il_radius,il_shape(3)) 734 ! coef indices to be used 735 il_k1 = il_radius-(jk-il_kmin)+1 736 il_k2 = il_radius+(il_kmax-jk)+1 917 737 IF( il_dim(3) == 1 )THEN 918 738 il_kmin=jk 919 739 il_kmax=jk 740 ! coef indices to be used 741 il_k1 = 1 742 il_k2 = 1 920 743 ENDIF 921 744 … … 925 748 & il_kmin:il_kmax, & 926 749 & jl), dd_fill, il_radius, & 927 & dl_coef(:,:,:) ) 750 & dl_coef(il_i1:il_i2, & 751 & il_j1:il_j2, & 752 & il_k1:il_k2) ) 928 753 929 754 IF( dd_value(ji,jj,jk,jl) /= dd_fill )THEN 930 755 il_detect(ji,jj,jk)= 0 756 ll_iter=.FALSE. 757 ENDIF 758 759 ENDIF 760 761 ENDDO 762 ENDDO 763 ! from South East(il_shape(1),il_shape(2)) to North West(1,1) 764 IF( ALL(il_detect(:,:,jk) == 0) ) CYCLE 765 DO jj=il_shape(2),1,-1 766 IF( ALL(il_detect(:,jj,jk) == 0) ) CYCLE 767 DO ji=il_shape(1),1,-1 768 769 IF( il_detect(ji,jj,jk) == 1 )THEN 770 771 il_imin=MAX(ji-il_radius,1) 772 il_imax=MIN(ji+il_radius,il_shape(1)) 773 ! coef indices to be used 774 il_i1 = il_radius-(ji-il_imin)+1 775 il_i2 = il_radius+(il_imax-ji)+1 776 IF( il_dim(1) == 1 )THEN 777 il_imin=ji 778 il_imax=ji 779 ! coef indices to be used 780 il_i1 = 1 781 il_i2 = 1 782 ENDIF 783 784 il_jmin=MAX(jj-il_radius,1) 785 il_jmax=MIN(jj+il_radius,il_shape(2)) 786 ! coef indices to be used 787 il_j1 = il_radius-(jj-il_jmin)+1 788 il_j2 = il_radius+(il_jmax-jj)+1 789 IF( il_dim(2) == 1 )THEN 790 il_jmin=jj 791 il_jmax=jj 792 ! coef indices to be used 793 il_j1 = 1 794 il_j2 = 1 795 ENDIF 796 797 il_kmin=MAX(jk-il_radius,1) 798 il_kmax=MIN(jk+il_radius,il_shape(3)) 799 ! coef indices to be used 800 il_k1 = il_radius-(jk-il_kmin)+1 801 il_k2 = il_radius+(il_kmax-jk)+1 802 IF( il_dim(3) == 1 )THEN 803 il_kmin=jk 804 il_kmax=jk 805 ! coef indices to be used 806 il_k1 = 1 807 il_k2 = 1 808 ENDIF 809 810 dd_value(ji,jj,jk,jl)=extrap__3D_dist_weight_fill( & 811 & dd_value( il_imin:il_imax, & 812 & il_jmin:il_jmax, & 813 & il_kmin:il_kmax, & 814 & jl), dd_fill, il_radius, & 815 & dl_coef(il_i1:il_i2, & 816 & il_j1:il_j2, & 817 & il_k1:il_k2) ) 818 819 IF( dd_value(ji,jj,jk,jl) /= dd_fill )THEN 820 il_detect(ji,jj,jk)= 0 821 ll_iter=.FALSE. 931 822 ENDIF 932 823 … … 936 827 ENDDO 937 828 ENDDO 938 829 CALL logger_info(" EXTRAP 3D: "//& 830 & TRIM(fct_str(SUM(il_detect(:,:,:))))//& 831 & " point(s) to extrapolate " ) 832 939 833 DEALLOCATE( dl_coef ) 940 il_iter=il_iter+1834 IF( ll_iter ) il_iter=il_iter+1 941 835 ENDDO 942 836 ENDDO … … 946 840 947 841 END SUBROUTINE extrap__3D 948 !-------------------------------------------------------------------949 !> @brief950 !> This function compute derivative of 1D array.951 !>952 !> @details953 !> optionaly you could specify to take into account east west discontinuity954 !> (-180° 180° or 0° 360° for longitude variable)955 !>956 !> @author J.Paul957 !> - November, 2013- Initial Version958 !959 !> @param[in] dd_value 1D array of variable to be extrapolated960 !> @param[in] dd_fill FillValue of variable961 !> @param[in] ld_discont logical to take into account east west discontinuity962 !-------------------------------------------------------------------963 PURE FUNCTION extrap_deriv_1D( dd_value, dd_fill, ld_discont )964 965 IMPLICIT NONE966 ! Argument967 REAL(dp) , DIMENSION(:), INTENT(IN) :: dd_value968 REAL(dp) , INTENT(IN) :: dd_fill969 LOGICAL , INTENT(IN), OPTIONAL :: ld_discont970 971 ! function972 REAL(dp), DIMENSION(SIZE(dd_value,DIM=1) ) :: extrap_deriv_1D973 974 ! local variable975 INTEGER(i4) :: il_imin976 INTEGER(i4) :: il_imax977 INTEGER(i4), DIMENSION(1) :: il_shape978 979 REAL(dp) :: dl_min980 REAL(dp) :: dl_max981 REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_value982 983 LOGICAL :: ll_discont984 985 ! loop indices986 INTEGER(i4) :: ji987 988 INTEGER(i4) :: i1989 INTEGER(i4) :: i2990 !----------------------------------------------------------------991 ! init992 extrap_deriv_1D(:)=dd_fill993 994 ll_discont=.FALSE.995 IF( PRESENT(ld_discont) ) ll_discont=ld_discont996 997 il_shape(:)=SHAPE(dd_value(:))998 999 ALLOCATE( dl_value(3))1000 1001 ! compute derivative in i-direction1002 DO ji=1,il_shape(1)1003 1004 il_imin=MAX(ji-1,1)1005 il_imax=MIN(ji+1,il_shape(1))1006 1007 IF( il_imin==ji-1 .AND. il_imax==ji+1 )THEN1008 i1=1 ; i2=31009 ELSEIF( il_imin==ji .AND. il_imax==ji+1 )THEN1010 i1=1 ; i2=21011 ELSEIF( il_imin==ji-1 .AND. il_imax==ji )THEN1012 i1=2 ; i2=31013 ENDIF1014 1015 dl_value(i1:i2)=dd_value(il_imin:il_imax)1016 IF( il_imin == 1 )THEN1017 dl_value(:)=EOSHIFT( dl_value(:), &1018 & DIM=1, &1019 & SHIFT=-1, &1020 & BOUNDARY=dl_value(1) )1021 ENDIF1022 IF( il_imax == il_shape(1) )THEN1023 dl_value(:)=EOSHIFT( dl_value(:), &1024 & DIM=1, &1025 & SHIFT=1, &1026 & BOUNDARY=dl_value(3))1027 ENDIF1028 1029 IF( ll_discont )THEN1030 dl_min=MINVAL( dl_value(:), dl_value(:)/=dd_fill )1031 dl_max=MAXVAL( dl_value(:), dl_value(:)/=dd_fill )1032 IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN1033 WHERE( dl_value(:) < 0._dp )1034 dl_value(:) = dl_value(:)+360._dp1035 END WHERE1036 ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN1037 WHERE( dl_value(:) > 180._dp )1038 dl_value(:) = dl_value(:)-180._dp1039 END WHERE1040 ENDIF1041 ENDIF1042 1043 IF( dl_value( 2) /= dd_fill .AND. & ! ji1044 & dl_value( 3) /= dd_fill .AND. & ! ji+11045 & dl_value( 1) /= dd_fill )THEN ! ji-11046 1047 extrap_deriv_1D(ji)=&1048 & ( dl_value(3) - dl_value(1) ) / &1049 & REAL( il_imax-il_imin ,dp)1050 1051 ENDIF1052 1053 ENDDO1054 1055 DEALLOCATE( dl_value )1056 1057 END FUNCTION extrap_deriv_1D1058 !-------------------------------------------------------------------1059 !> @brief1060 !> This function compute derivative of 2D array.1061 !> you have to specify in which direction derivative have to be computed:1062 !> first (I) or second (J) dimension.1063 !>1064 !> @details1065 !> optionaly you could specify to take into account east west discontinuity1066 !> (-180° 180° or 0° 360° for longitude variable)1067 !>1068 !> @author J.Paul1069 !> - November, 2013- Initial Version1070 !1071 !> @param[in] dd_value 2D array of variable to be extrapolated1072 !> @param[in] dd_fill FillValue of variable1073 !> @param[in] cd_dim compute derivative on first (I) or second (J) dimension1074 !> @param[in] ld_discont logical to take into account east west discontinuity1075 !-------------------------------------------------------------------1076 FUNCTION extrap_deriv_2D( dd_value, dd_fill, cd_dim, ld_discont )1077 1078 IMPLICIT NONE1079 ! Argument1080 REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_value1081 REAL(dp) , INTENT(IN) :: dd_fill1082 CHARACTER(LEN=*) , INTENT(IN) :: cd_dim1083 LOGICAL , INTENT(IN), OPTIONAL :: ld_discont1084 1085 ! function1086 REAL(dp), DIMENSION(SIZE(dd_value,DIM=1), &1087 & SIZE(dd_value,DIM=2) ) :: extrap_deriv_2D1088 1089 ! local variable1090 INTEGER(i4) :: il_imin1091 INTEGER(i4) :: il_imax1092 INTEGER(i4) :: il_jmin1093 INTEGER(i4) :: il_jmax1094 INTEGER(i4), DIMENSION(2) :: il_shape1095 1096 REAL(dp) :: dl_min1097 REAL(dp) :: dl_max1098 REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_value1099 1100 LOGICAL :: ll_discont1101 1102 ! loop indices1103 INTEGER(i4) :: ji1104 INTEGER(i4) :: jj1105 1106 INTEGER(i4) :: i11107 INTEGER(i4) :: i21108 1109 INTEGER(i4) :: j11110 INTEGER(i4) :: j21111 !----------------------------------------------------------------1112 ! init1113 extrap_deriv_2D(:,:)=dd_fill1114 1115 ll_discont=.FALSE.1116 IF( PRESENT(ld_discont) ) ll_discont=ld_discont1117 1118 il_shape(:)=SHAPE(dd_value(:,:))1119 1120 SELECT CASE(TRIM(fct_upper(cd_dim)))1121 1122 CASE('I')1123 1124 ALLOCATE( dl_value(3,il_shape(2)) )1125 ! compute derivative in i-direction1126 DO ji=1,il_shape(1)1127 1128 ! init1129 dl_value(:,:)=dd_fill1130 1131 il_imin=MAX(ji-1,1)1132 il_imax=MIN(ji+1,il_shape(1))1133 1134 IF( il_imin==ji-1 .AND. il_imax==ji+1 )THEN1135 i1=1 ; i2=31136 ELSEIF( il_imin==ji .AND. il_imax==ji+1 )THEN1137 i1=1 ; i2=21138 ELSEIF( il_imin==ji-1 .AND. il_imax==ji )THEN1139 i1=2 ; i2=31140 ENDIF1141 1142 dl_value(i1:i2,:)=dd_value(il_imin:il_imax,:)1143 IF( il_imin == 1 )THEN1144 dl_value(:,:)=EOSHIFT( dl_value(:,:), &1145 & DIM=1, &1146 & SHIFT=-1, &1147 & BOUNDARY=dl_value(1,:) )1148 ENDIF1149 IF( il_imax == il_shape(1) )THEN1150 dl_value(:,:)=EOSHIFT( dl_value(:,:), &1151 & DIM=1, &1152 & SHIFT=1, &1153 & BOUNDARY=dl_value(3,:))1154 ENDIF1155 1156 IF( ll_discont )THEN1157 dl_min=MINVAL( dl_value(:,:), dl_value(:,:)/=dd_fill )1158 dl_max=MAXVAL( dl_value(:,:), dl_value(:,:)/=dd_fill )1159 IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN1160 WHERE( dl_value(:,:) < 0_dp )1161 dl_value(:,:) = dl_value(:,:)+360._dp1162 END WHERE1163 ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN1164 WHERE( dl_value(:,:) > 180 )1165 dl_value(:,:) = dl_value(:,:)-180._dp1166 END WHERE1167 ENDIF1168 ENDIF1169 1170 WHERE( dl_value(2,:) /= dd_fill .AND. & ! ji1171 & dl_value(3,:) /= dd_fill .AND. & ! ji+11172 & dl_value(1,:) /= dd_fill ) ! ji-11173 1174 extrap_deriv_2D(ji,:)=&1175 & ( dl_value(3,:) - dl_value(1,:) ) / &1176 & REAL( il_imax-il_imin,dp)1177 1178 END WHERE1179 1180 ENDDO1181 1182 CASE('J')1183 1184 ALLOCATE( dl_value(il_shape(1),3) )1185 ! compute derivative in j-direction1186 DO jj=1,il_shape(2)1187 1188 il_jmin=MAX(jj-1,1)1189 il_jmax=MIN(jj+1,il_shape(2))1190 1191 IF( il_jmin==jj-1 .AND. il_jmax==jj+1 )THEN1192 j1=1 ; j2=31193 ELSEIF( il_jmin==jj .AND. il_jmax==jj+1 )THEN1194 j1=1 ; j2=21195 ELSEIF( il_jmin==jj-1 .AND. il_jmax==jj )THEN1196 j1=2 ; j2=31197 ENDIF1198 1199 dl_value(:,j1:j2)=dd_value(:,il_jmin:il_jmax)1200 IF( il_jmin == 1 )THEN1201 dl_value(:,:)=EOSHIFT( dl_value(:,:), &1202 & DIM=2, &1203 & SHIFT=-1, &1204 & BOUNDARY=dl_value(:,1))1205 ENDIF1206 IF( il_jmax == il_shape(2) )THEN1207 dl_value(:,:)=EOSHIFT( dl_value(:,:), &1208 & DIM=2, &1209 & SHIFT=1, &1210 & BOUNDARY=dl_value(:,3))1211 ENDIF1212 1213 IF( ll_discont )THEN1214 dl_min=MINVAL( dl_value(:,:), dl_value(:,:)/=dd_fill )1215 dl_max=MAXVAL( dl_value(:,:), dl_value(:,:)/=dd_fill )1216 IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN1217 WHERE( dl_value(:,:) < 0_dp )1218 dl_value(:,:) = dl_value(:,:)+360._dp1219 END WHERE1220 ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN1221 WHERE( dl_value(:,:) > 180 )1222 dl_value(:,:) = dl_value(:,:)-180._dp1223 END WHERE1224 ENDIF1225 ENDIF1226 1227 WHERE( dl_value(:, 2) /= dd_fill .AND. & ! jj1228 & dl_value(:, 3) /= dd_fill .AND. & ! jj+11229 & dl_value(:, 1) /= dd_fill ) ! jj-11230 1231 extrap_deriv_2D(:,jj)=&1232 & ( dl_value(:,3) - dl_value(:,1) ) / &1233 & REAL(il_jmax-il_jmin,dp)1234 1235 END WHERE1236 1237 ENDDO1238 1239 END SELECT1240 1241 DEALLOCATE( dl_value )1242 1243 END FUNCTION extrap_deriv_2D1244 !-------------------------------------------------------------------1245 !> @brief1246 !> This function compute derivative of 3D array.1247 !> you have to specify in which direction derivative have to be computed:1248 !> first (I), second (J) or third (K) dimension.1249 !>1250 !> @details1251 !> optionaly you could specify to take into account east west discontinuity1252 !> (-180° 180° or 0° 360° for longitude variable)1253 !>1254 !> @author J.Paul1255 !> - November, 2013- Initial Version1256 !1257 !> @param[inout] dd_value 3D array of variable to be extrapolated1258 !> @param[in] dd_fill FillValue of variable1259 !> @param[in] cd_dim compute derivative on first (I) second (J) or third (K) dimension1260 !> @param[in] ld_discont logical to take into account east west discontinuity1261 !-------------------------------------------------------------------1262 PURE FUNCTION extrap_deriv_3D( dd_value, dd_fill, cd_dim, ld_discont )1263 1264 IMPLICIT NONE1265 ! Argument1266 REAL(dp) , DIMENSION(:,:,:), INTENT(IN) :: dd_value1267 REAL(dp) , INTENT(IN) :: dd_fill1268 CHARACTER(LEN=*) , INTENT(IN) :: cd_dim1269 LOGICAL , INTENT(IN), OPTIONAL :: ld_discont1270 1271 ! function1272 REAL(dp), DIMENSION(SIZE(dd_value,DIM=1), &1273 & SIZE(dd_value,DIM=2), &1274 & SIZE(dd_value,DIM=3)) :: extrap_deriv_3D1275 1276 ! local variable1277 INTEGER(i4) :: il_imin1278 INTEGER(i4) :: il_imax1279 INTEGER(i4) :: il_jmin1280 INTEGER(i4) :: il_jmax1281 INTEGER(i4) :: il_kmin1282 INTEGER(i4) :: il_kmax1283 INTEGER(i4), DIMENSION(3) :: il_shape1284 1285 REAL(dp) :: dl_min1286 REAL(dp) :: dl_max1287 REAL(dp) , DIMENSION(:,:,:), ALLOCATABLE :: dl_value1288 1289 LOGICAL :: ll_discont1290 1291 ! loop indices1292 INTEGER(i4) :: ji1293 INTEGER(i4) :: jj1294 INTEGER(i4) :: jk1295 1296 INTEGER(i4) :: i11297 INTEGER(i4) :: i21298 1299 INTEGER(i4) :: j11300 INTEGER(i4) :: j21301 1302 INTEGER(i4) :: k11303 INTEGER(i4) :: k21304 !----------------------------------------------------------------1305 ! init1306 extrap_deriv_3D(:,:,:)=dd_fill1307 1308 ll_discont=.FALSE.1309 IF( PRESENT(ld_discont) ) ll_discont=ld_discont1310 1311 il_shape(:)=SHAPE(dd_value(:,:,:))1312 1313 1314 SELECT CASE(TRIM(fct_upper(cd_dim)))1315 1316 CASE('I')1317 1318 ALLOCATE( dl_value(3,il_shape(2),il_shape(3)) )1319 ! compute derivative in i-direction1320 DO ji=1,il_shape(1)1321 1322 il_imin=MAX(ji-1,1)1323 il_imax=MIN(ji+1,il_shape(1))1324 1325 IF( il_imin==ji-1 .AND. il_imax==ji+1 )THEN1326 i1=1 ; i2=31327 ELSEIF( il_imin==ji .AND. il_imax==ji+1 )THEN1328 i1=1 ; i2=21329 ELSEIF( il_imin==ji-1 .AND. il_imax==ji )THEN1330 i1=2 ; i2=31331 ENDIF1332 1333 dl_value(i1:i2,:,:)=dd_value(il_imin:il_imax,:,:)1334 IF( il_imin == 1 )THEN1335 dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), &1336 & DIM=1, &1337 & SHIFT=-1, &1338 & BOUNDARY=dl_value(1,:,:) )1339 ENDIF1340 IF( il_imax == il_shape(1) )THEN1341 dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), &1342 & DIM=1, &1343 & SHIFT=1, &1344 & BOUNDARY=dl_value(3,:,:))1345 ENDIF1346 1347 IF( ll_discont )THEN1348 dl_min=MINVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill )1349 dl_max=MAXVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill )1350 IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN1351 WHERE( dl_value(:,:,:) < 0_dp )1352 dl_value(:,:,:) = dl_value(:,:,:)+360._dp1353 END WHERE1354 ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN1355 WHERE( dl_value(:,:,:) > 180 )1356 dl_value(:,:,:) = dl_value(:,:,:)-180._dp1357 END WHERE1358 ENDIF1359 ENDIF1360 1361 WHERE( dl_value(2,:,:) /= dd_fill .AND. & ! ji1362 & dl_value(3,:,:) /= dd_fill .AND. & !ji+11363 & dl_value(1,:,:) /= dd_fill ) !ji-11364 1365 extrap_deriv_3D(ji,:,:)= &1366 & ( dl_value(3,:,:) - dl_value(1,:,:) ) / &1367 & REAL( il_imax-il_imin ,dp)1368 1369 END WHERE1370 1371 ENDDO1372 1373 CASE('J')1374 1375 ALLOCATE( dl_value(il_shape(1),3,il_shape(3)) )1376 ! compute derivative in j-direction1377 DO jj=1,il_shape(2)1378 1379 il_jmin=MAX(jj-1,1)1380 il_jmax=MIN(jj+1,il_shape(2))1381 1382 IF( il_jmin==jj-1 .AND. il_jmax==jj+1 )THEN1383 j1=1 ; j2=31384 ELSEIF( il_jmin==jj .AND. il_jmax==jj+1 )THEN1385 j1=1 ; j2=21386 ELSEIF( il_jmin==jj-1 .AND. il_jmax==jj )THEN1387 j1=2 ; j2=31388 ENDIF1389 1390 dl_value(:,j1:j2,:)=dd_value(:,il_jmin:il_jmax,:)1391 IF( il_jmin == 1 )THEN1392 dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), &1393 & DIM=2, &1394 & SHIFT=-1, &1395 & BOUNDARY=dl_value(:,1,:) )1396 ENDIF1397 IF( il_jmax == il_shape(2) )THEN1398 dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), &1399 & DIM=2, &1400 & SHIFT=1, &1401 & BOUNDARY=dl_value(:,3,:))1402 ENDIF1403 1404 IF( ll_discont )THEN1405 dl_min=MINVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill )1406 dl_max=MAXVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill )1407 IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN1408 WHERE( dl_value(:,:,:) < 0_dp )1409 dl_value(:,:,:) = dl_value(:,:,:)+360._dp1410 END WHERE1411 ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN1412 WHERE( dl_value(:,:,:) > 180 )1413 dl_value(:,:,:) = dl_value(:,:,:)-180._dp1414 END WHERE1415 ENDIF1416 ENDIF1417 1418 WHERE( dl_value(:, 2,:) /= dd_fill .AND. & ! jj1419 & dl_value(:, 3,:) /= dd_fill .AND. & ! jj+11420 & dl_value(:, 1,:) /= dd_fill ) ! jj-11421 1422 extrap_deriv_3D(:,jj,:)=&1423 & ( dl_value(:,3,:) - dl_value(:,1,:) ) / &1424 & REAL( il_jmax - il_jmin ,dp)1425 1426 END WHERE1427 1428 ENDDO1429 1430 CASE('K')1431 ! compute derivative in k-direction1432 DO jk=1,il_shape(3)1433 1434 il_kmin=MAX(jk-1,1)1435 il_kmax=MIN(jk+1,il_shape(3))1436 1437 IF( il_kmin==jk-1 .AND. il_kmax==jk+1 )THEN1438 k1=1 ; k2=31439 ELSEIF( il_kmin==jk .AND. il_kmax==jk+1 )THEN1440 k1=1 ; k2=21441 ELSEIF( il_kmin==jk-1 .AND. il_kmax==jk )THEN1442 k1=2 ; k2=31443 ENDIF1444 1445 dl_value(:,:,k1:k2)=dd_value(:,:,il_kmin:il_kmax)1446 IF( il_kmin == 1 )THEN1447 dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), &1448 & DIM=3, &1449 & SHIFT=-1, &1450 & BOUNDARY=dl_value(:,:,1) )1451 ENDIF1452 IF( il_kmax == il_shape(3) )THEN1453 dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), &1454 & DIM=3, &1455 & SHIFT=1, &1456 & BOUNDARY=dl_value(:,:,3))1457 ENDIF1458 1459 IF( ll_discont )THEN1460 dl_min=MINVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill )1461 dl_max=MAXVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill )1462 IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN1463 WHERE( dl_value(:,:,:) < 0_dp )1464 dl_value(:,:,:) = dl_value(:,:,:)+360._dp1465 END WHERE1466 ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN1467 WHERE( dl_value(:,:,:) > 180 )1468 dl_value(:,:,:) = dl_value(:,:,:)-180._dp1469 END WHERE1470 ENDIF1471 ENDIF1472 1473 WHERE( dl_value(:,:, 2) /= dd_fill .AND. & ! jk1474 & dl_value(:,:, 3) /= dd_fill .AND. & ! jk+11475 & dl_value(:,:, 1) /= dd_fill ) ! jk-11476 1477 extrap_deriv_3D(:,:,jk)=&1478 & ( dl_value(:,:,3) - dl_value(:,:,1) ) / &1479 & REAL( il_kmax-il_kmin,dp)1480 1481 END WHERE1482 1483 ENDDO1484 1485 END SELECT1486 1487 DEALLOCATE( dl_value )1488 1489 END FUNCTION extrap_deriv_3D1490 842 !------------------------------------------------------------------- 1491 843 !> @brief … … 1493 845 !> 1494 846 !> @details 1495 !> coefficients are "grid distance" to the center of the box choosed to compute1496 !> extrapolation.847 !> coefficients are "grid distance" to the center of the box 848 !> choosed to compute extrapolation. 1497 849 !> 1498 850 !> @author J.Paul 1499 !> - November, 2013- Initial Version 851 !> @date November, 2013 - Initial Version 852 !> @date July, 2015 853 !> - decrease weight of third dimension 1500 854 ! 1501 855 !> @param[in] dd_value 3D array of variable to be extrapolated … … 1544 898 1545 899 ! compute distance 900 ! "vertical weight" is lower than horizontal 1546 901 dl_dist(ji,jj,jk) = (ji-il_imid)**2 + & 1547 902 & (jj-il_jmid)**2 + & 1548 & 903 & 3*(jk-il_kmid)**2 1549 904 1550 905 IF( dl_dist(ji,jj,jk) /= 0 )THEN … … 1569 924 !> 1570 925 !> @author J.Paul 1571 !> - November, 2013- Initial Version926 !> @date November, 2013 - Initial Version 1572 927 !> 1573 928 !> @param[in] dd_value 3D array of variable to be extrapolated … … 1658 1013 !> 1659 1014 !> @author J.Paul 1660 !> - November, 2013- Initial Version 1015 !> @date November, 2013 - Initial Version 1016 !> @date July, 2015 1017 !> - decrease weight of third dimension 1661 1018 ! 1662 1019 !> @param[in] dd_value 3D array of variable to be extrapolated … … 1705 1062 1706 1063 ! compute distance 1064 ! "vertical weight" is lower than horizontal 1707 1065 dl_dist(ji,jj,jk) = (ji-il_imid)**2 + & 1708 1066 & (jj-il_jmid)**2 + & 1709 & 1067 & 3*(jk-il_kmid)**2 1710 1068 1711 1069 IF( dl_dist(ji,jj,jk) /= 0 )THEN … … 1732 1090 !> 1733 1091 !> @author J.Paul 1734 !> - November, 2013- Initial Version1092 !> @date November, 2013 - Initial Version 1735 1093 ! 1736 1094 !> @param[in] dd_value 3D array of variable to be extrapolated … … 1763 1121 INTEGER(i4) :: jj 1764 1122 INTEGER(i4) :: jk 1765 1766 1123 !---------------------------------------------------------------- 1767 1124 … … 1793 1150 ENDDO 1794 1151 ENDDO 1152 1795 1153 1796 1154 ! return value … … 1815 1173 !> 1816 1174 !> @author J.Paul 1817 !> - November, 2013-Initial version1175 !> @date November, 2013 - Initial version 1818 1176 ! 1819 1177 !> @param[inout] td_var variable … … 1917 1275 !> 1918 1276 !> @author J.Paul 1919 !> - November, 2013-Initial version1277 !> @date November, 2013 - Initial version 1920 1278 !> 1921 1279 !> @param[inout] td_var variable -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/file.f90
r5037 r6487 137 137 !> J.Paul 138 138 ! REVISION HISTORY: 139 !> @date November, 2013- Initial Version 140 !> @date November, 2014 - Fix memory leaks bug 139 !> @date November, 2013 - Initial Version 140 !> @date November, 2014 141 !> - Fix memory leaks bug 141 142 !> 142 143 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 288 289 !> 289 290 !> @author J.Paul 290 !> - November, 2013- Initial Version291 !> @date November, 2013 - Initial Version 291 292 !> @date November, 2014 292 !> 293 !> - use function instead of overload assignment operator 293 294 !> (to avoid memory leak) 294 295 ! … … 409 410 !> 410 411 !> @author J.Paul 411 !> - November, 2013- Initial Version412 !> @date November, 2013 - Initial Version 412 413 !> @date November, 2014 413 !> 414 !> - use function instead of overload assignment operator 414 415 !> (to avoid memory leak) 415 416 ! … … 448 449 ! 449 450 !> @author J.Paul 450 !> - November, 2013- Initial Version451 !> @date November, 2013 - Initial Version 451 452 ! 452 453 !> @param[in] cd_file file name … … 553 554 ! 554 555 !> @author J.Paul 555 !> - November, 2013- Initial Version556 !> @date November, 2013 - Initial Version 556 557 ! 557 558 !> @param[in] cd_file file name … … 589 590 ! 590 591 !> @author J.Paul 591 !> - November, 2013- Initial Version592 !> @date November, 2013 - Initial Version 592 593 ! 593 594 !> @param[in] td_file file structure … … 604 605 CHARACTER(LEN=lc) :: cl_dim 605 606 LOGICAL :: ll_error 606 607 INTEGER(i4) :: il_ind 607 LOGICAL :: ll_warn 608 609 INTEGER(i4) :: il_ind 608 610 609 611 ! loop indices … … 614 616 ! check used dimension 615 617 ll_error=.FALSE. 618 ll_warn=.FALSE. 616 619 DO ji=1,ip_maxdim 617 620 il_ind=dim_get_index( td_file%t_dim(:), & … … 619 622 & TRIM(td_var%t_dim(ji)%c_sname)) 620 623 IF( il_ind /= 0 )THEN 621 IF( td_var%t_dim(ji)%l_use .AND. & 622 & td_file%t_dim(il_ind)%l_use .AND. & 623 & td_var%t_dim(ji)%i_len /= td_file%t_dim(il_ind)%i_len )THEN 624 ll_error=.TRUE. 625 ENDIF 624 IF( td_var%t_dim(ji)%l_use .AND. & 625 & td_file%t_dim(il_ind)%l_use .AND. & 626 & td_var%t_dim(ji)%i_len /= td_file%t_dim(il_ind)%i_len )THEN 627 IF( INDEX( TRIM(td_var%c_axis), & 628 & TRIM(fct_upper(td_var%t_dim(ji)%c_name))) == 0 )THEN 629 ll_warn=.TRUE. 630 ELSE 631 ll_error=.TRUE. 632 ENDIF 633 ENDIF 626 634 ENDIF 627 635 ENDDO 628 636 629 637 IF( ll_error )THEN 630 631 file_check_var_dim=.FALSE.632 633 CALL logger_error( &634 & " FILE CHECK VAR DIM: variable and file dimension differ"//&635 & " for variable "//TRIM(td_var%c_name)//&636 & " and file "//TRIM(td_file%c_name))637 638 638 639 639 cl_dim='(/' … … 659 659 CALL logger_debug( " variable dimension: "//TRIM(cl_dim) ) 660 660 661 file_check_var_dim=.FALSE. 662 663 CALL logger_error( & 664 & " FILE CHECK VAR DIM: variable and file dimension differ"//& 665 & " for variable "//TRIM(td_var%c_name)//& 666 & " and file "//TRIM(td_file%c_name)) 667 668 ELSEIF( ll_warn )THEN 669 CALL logger_warn( & 670 & " FILE CHECK VAR DIM: variable and file dimension differ"//& 671 & " for variable "//TRIM(td_var%c_name)//& 672 & " and file "//TRIM(td_file%c_name)//". you should use"//& 673 & " var_check_dim to remove useless dimension.") 661 674 ELSE 662 675 … … 679 692 ! 680 693 !> @author J.Paul 681 !> - November, 2013- Initial Version694 !> @date November, 2013 - Initial Version 682 695 !> @date September, 2014 683 696 !> - add dimension to file if need be … … 707 720 IF( TRIM(td_file%c_name) == '' )THEN 708 721 709 CALL logger_error( " FILE ADD VAR: structure file unknown" )710 722 CALL logger_debug( " FILE ADD VAR: you should have used file_init before "//& 711 723 & "running file_add_var" ) 724 CALL logger_error( " FILE ADD VAR: structure file unknown" ) 712 725 713 726 ELSE … … 723 736 & td_var%c_stdname ) 724 737 ENDIF 725 738 CALL logger_debug( & 739 & " FILE ADD VAR: ind "//TRIM(fct_str(il_ind)) ) 726 740 IF( il_ind /= 0 )THEN 727 741 … … 739 753 ELSE 740 754 741 CALL logger_ trace( &755 CALL logger_debug( & 742 756 & " FILE ADD VAR: add variable "//TRIM(td_var%c_name)//& 743 757 & ", standard name "//TRIM(td_var%c_stdname)//& … … 770 784 !il_rec=td_file%t_dim(3)%i_len 771 785 END SELECT 772 CALL logger_info( &773 & " FILE ADD VAR: variable index "//TRIM(fct_str(il_ind)))774 786 775 787 IF( td_file%i_nvar > 0 )THEN … … 806 818 ENDIF 807 819 808 IF( il_ind < td_file%i_nvar )THEN820 IF( il_ind < td_file%i_nvar+1 )THEN 809 821 ! variable with more dimension than new variable 810 822 td_file%t_var( il_ind+1 : td_file%i_nvar+1 ) = & … … 893 905 ! 894 906 !> @author J.Paul 895 !> - November, 2013- Initial Version 907 !> @date November, 2013 - Initial Version 908 !> @date February, 2015 909 !> - define local variable structure to avoid mistake with pointer 896 910 ! 897 911 !> @param[inout] td_file file structure … … 907 921 ! local variable 908 922 INTEGER(i4) :: il_ind 923 TYPE(TVAR) :: tl_var 909 924 !---------------------------------------------------------------- 910 925 … … 928 943 IF( il_ind /= 0 )THEN 929 944 930 CALL file_del_var(td_file, td_file%t_var(il_ind)) 945 tl_var=var_copy(td_file%t_var(il_ind)) 946 CALL file_del_var(td_file, tl_var) 931 947 932 948 ELSE 933 949 934 CALL logger_ warn( &950 CALL logger_debug( & 935 951 & " FILE DEL VAR NAME: there is no variable with name or "//& 936 952 & "standard name "//TRIM(cd_name)//" in file "//& … … 953 969 !> 954 970 !> @author J.Paul 955 !> - November, 2013- Initial Version971 !> @date November, 2013 - Initial Version 956 972 !> 957 973 !> @param[inout] td_file file structure … … 1096 1112 ! 1097 1113 !> @author J.Paul 1098 !> - November, 2013- Initial Version1114 !> @date November, 2013 - Initial Version 1099 1115 ! 1100 1116 !> @param[inout] td_file file structure … … 1131 1147 ! 1132 1148 !> @author J.Paul 1133 !> - November, 2013- Initial Version1149 !> @date November, 2013 - Initial Version 1134 1150 ! 1135 1151 !> @param[inout] td_file file structure … … 1247 1263 ! 1248 1264 !> @author J.Paul 1249 !> - November, 2013- Initial Version 1265 !> @date November, 2013 - Initial Version 1266 !> @date February, 2015 1267 !> - define local attribute structure to avoid mistake 1268 !> with pointer 1250 1269 ! 1251 1270 !> @param[inout] td_file file structure … … 1261 1280 ! local variable 1262 1281 INTEGER(i4) :: il_ind 1282 TYPE(TATT) :: tl_att 1263 1283 !---------------------------------------------------------------- 1264 1284 … … 1282 1302 IF( il_ind /= 0 )THEN 1283 1303 1284 CALL file_del_att(td_file, td_file%t_att(il_ind)) 1304 tl_att=att_copy(td_file%t_att(il_ind)) 1305 CALL file_del_att(td_file, tl_att) 1285 1306 1286 1307 ELSE 1287 1308 1288 CALL logger_ warn( &1309 CALL logger_debug( & 1289 1310 & " FILE DEL ATT NAME: there is no attribute with name "//& 1290 1311 & TRIM(cd_name)//" in file "//TRIM(td_file%c_name)) … … 1305 1326 ! 1306 1327 !> @author J.Paul 1307 !> - November, 2013- Initial Version1328 !> @date November, 2013 - Initial Version 1308 1329 ! 1309 1330 !> @param[inout] td_file file structure … … 1403 1424 ! 1404 1425 !> @author J.Paul 1405 !> - November, 2013- Initial Version1426 !> @date November, 2013 - Initial Version 1406 1427 ! 1407 1428 !> @param[inout] td_file file structure … … 1444 1465 ! 1445 1466 !> @author J.Paul 1446 !> - November, 2013- Initial Version1467 !> @date November, 2013 - Initial Version 1447 1468 !> @date September, 2014 1448 1469 !> - do not reorder dimension, before put in file … … 1529 1550 !> 1530 1551 !> @author J.Paul 1531 !> - November, 2013- Initial Version1552 !> @date November, 2013 - Initial Version 1532 1553 ! 1533 1554 !> @param[inout] td_file file structure … … 1609 1630 ! 1610 1631 !> @author J.Paul 1611 !> - November, 2013- Initial Version1632 !> @date November, 2013 - Initial Version 1612 1633 ! 1613 1634 !> @param[inout] td_file file structure … … 1652 1673 ! 1653 1674 !> @author J.Paul 1654 !> - November, 2013- Initial Version1675 !> @date November, 2013 - Initial Version 1655 1676 ! 1656 1677 !> @param[in] td_file file structure … … 1717 1738 WRITE(*,'(/a)') " File variable" 1718 1739 DO ji=1,td_file%i_nvar 1719 CALL var_print(td_file%t_var(ji) )!,.FALSE.)1740 CALL var_print(td_file%t_var(ji),.FALSE.) 1720 1741 ENDDO 1721 1742 ENDIF … … 1730 1751 ! 1731 1752 !> @author J.Paul 1732 !> - November, 2013- Initial Version1753 !> @date November, 2013 - Initial Version 1733 1754 ! 1734 1755 !> @param[in] cd_file file structure … … 1769 1790 ! 1770 1791 !> @author J.Paul 1771 !> - November, 2013- Initial Version 1792 !> @date November, 2013 - Initial Version 1793 !> @date February, 2015 1794 !> - add case to not return date (yyyymmdd) at the end of filename 1795 !> @date February, 2015 1796 !> - add case to not return release number 1797 !> we assume release number only on one digit (ex : file_v3.5.nc) 1772 1798 ! 1773 1799 !> @param[in] cd_file file name (without suffix) … … 1803 1829 IF( .NOT. fct_is_num(file__get_number(2:)) )THEN 1804 1830 file__get_number='' 1831 ELSEIF( LEN(TRIM(file__get_number))-1 == 8 )THEN 1832 ! date case yyyymmdd 1833 file__get_number='' 1834 ELSEIF( LEN(TRIM(file__get_number))-1 == 1 )THEN 1835 ! release number case 1836 file__get_number='' 1805 1837 ENDIF 1806 1838 ELSE … … 1816 1848 ! 1817 1849 !> @author J.Paul 1818 !> - November, 2013- Initial Version1850 !> @date November, 2013 - Initial Version 1819 1851 ! 1820 1852 !> @param[in] td_file file structure … … 1879 1911 ! 1880 1912 !> @author J.Paul 1881 !> - November, 2013- Initial Version1913 !> @date November, 2013 - Initial Version 1882 1914 ! 1883 1915 !> @param[in] td_file file structure … … 1906 1938 ! 1907 1939 !> @author J.Paul 1908 !> - November, 2013- Initial Version1940 !> @date November, 2013 - Initial Version 1909 1941 ! 1910 1942 !> @param[in] td_file file structure … … 2019 2051 ! 2020 2052 !> @author J.Paul 2021 !> - November, 2013- Initial Version2053 !> @date November, 2013 - Initial Version 2022 2054 ! 2023 2055 !> @param[in] td_file array of file structure … … 2057 2089 !> 2058 2090 !> @author J.Paul 2059 !> - September, 2014- Initial Version2091 !> @date September, 2014 - Initial Version 2060 2092 ! 2061 2093 !> @param[in] td_file array of file -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/filter.f90
r5037 r6487 18 18 !> - rad > cutoff : @f$ filter=0 @f$ 19 19 !> - 'blackman' 20 !> - rad < cutoff : @f$ filter=0.42 + 0.5*COS(\pi*\frac{rad}{cutoff}) + 0.08*COS(2\pi*\frac{rad}{cutoff}) @f$ 20 !> - rad < cutoff : @f$ filter=0.42 + 0.5*COS(\pi*\frac{rad}{cutoff}) + 21 !> 0.08*COS(2\pi*\frac{rad}{cutoff}) @f$ 21 22 !> - rad > cutoff : @f$ filter=0 @f$ 22 23 !> - 'gauss' … … 29 30 !> 30 31 !> td_var\%c_filter(2) string character is the number of turn to be done<br/> 31 !> td_var\%c_filter(3) string character is the cut-off frequency (count in number of mesh grid)<br/> 32 !> td_var\%c_filter(4) string character is the halo radius (count in number of mesh grid)<br/> 33 !> td_var\%c_filter(5) string character is the alpha parameter (for gauss and butterworth method)<br/> 32 !> td_var\%c_filter(3) string character is the cut-off frequency 33 ! > (count in number of mesh grid)<br/> 34 !> td_var\%c_filter(4) string character is the halo radius 35 !> (count in number of mesh grid)<br/> 36 !> td_var\%c_filter(5) string character is the alpha parameter 37 !> (for gauss and butterworth method)<br/> 34 38 !> 35 39 !> @note Filter method could be specify for each variable in namelist _namvar_, … … 40 44 !> The number of turn is specify using '*' separator.<br/> 41 45 !> Example: 42 !> - cn_varinfo='varname1:2*hamming(@f$cutoff@f$,@f$radius@f$)', 'varname2:gauss(@f$cutoff@f$,@f$radius@f$,@f$\alpha@f$)' 46 !> - cn_varinfo='varname1:flt=2*hamming(@f$cutoff@f$,@f$radius@f$)', 47 !> 'varname2:flt=gauss(@f$cutoff@f$,@f$radius@f$,@f$\alpha@f$)' 43 48 !> 44 49 !> to filter variable value:<br/> … … 106 111 !> 107 112 !> @author J.Paul 108 !> - November, 2013- Initial Version113 !> @date November, 2013 - Initial Version 109 114 ! 110 115 !> @param[inout] td_var variable structure … … 250 255 !> 251 256 !> @author J.Paul 252 !> - November, 2013- Initial Version257 !> @date November, 2013 - Initial Version 253 258 ! 254 259 !> @param[inout] td_var variable … … 296 301 297 302 !3-extrapolate 298 CALL extrap_fill_value( td_var , id_iext=id_radius, id_jext=id_radius )303 CALL extrap_fill_value( td_var ) !, id_iext=id_radius, id_jext=id_radius ) 299 304 300 305 !4-filtering … … 341 346 ! 342 347 !> @author J.Paul 343 !> - November, 2013- Initial Version348 !> @date November, 2013 - Initial Version 344 349 ! 345 350 !> @param[inout] dd_value array of value to be filtered … … 393 398 !> 394 399 !> @author J.Paul 395 !> - November, 2013- Initial Version400 !> @date November, 2013 - Initial Version 396 401 ! 397 402 !> @param[inout] dd_value array of value to be filtered … … 439 444 !> 440 445 !> @author J.Paul 441 !> - November, 2013- Initial Version446 !> @date November, 2013 - Initial Version 442 447 ! 443 448 !> @param[inout] dd_value array of value to be filtered … … 482 487 !> 483 488 !> @author J.Paul 484 !> - November, 2013- Initial Version489 !> @date November, 2013 - Initial Version 485 490 ! 486 491 !> @param[inout] dd_value array of value to be filtered … … 537 542 !> 538 543 !> @author J.Paul 539 !> - Nov, 2013- Initial Version544 !> @date November, 2013 - Initial Version 540 545 ! 541 546 !> @param[inout] dd_value array of value to be filtered … … 590 595 ! 591 596 !> @author J.Paul 592 !> - November, 2013- Initial Version597 !> @date November, 2013 - Initial Version 593 598 ! 594 599 !> @param[in] cd_name filter name … … 649 654 ! 650 655 !> @author J.Paul 651 !> - November, 2013- Initial Version656 !> @date November, 2013 - Initial Version 652 657 ! 653 658 !> @param[in] cd_name filter name … … 695 700 ! 696 701 !> @author J.Paul 697 !> - November, 2013- Initial Version702 !> @date November, 2013 - Initial Version 698 703 ! 699 704 !> @param[in] dd_cutoff cut-off frequency … … 749 754 ! 750 755 !> @author J.Paul 751 !> - November, 2013- Initial Version756 !> @date November, 2013 - Initial Version 752 757 ! 753 758 !> @param[in] dd_cutoff cut-off frequency … … 808 813 ! 809 814 !> @author J.Paul 810 !> - November, 2013- Initial Version815 !> @date November, 2013 - Initial Version 811 816 ! 812 817 !> @param[in] dd_cutoff cut-off frequency … … 863 868 ! 864 869 !> @author J.Paul 865 !> - November, 2013- Initial Version870 !> @date November, 2013 - Initial Version 866 871 ! 867 872 !> @param[in] dd_cutoff cut-off frequency … … 922 927 ! 923 928 !> @author J.Paul 924 !> - November, 2013- Initial Version929 !> @date November, 2013 - Initial Version 925 930 ! 926 931 !> @param[in] dd_cutoff cut-off frequency … … 978 983 !> 979 984 !> @author J.Paul 980 !> - November, 2013- Initial Version985 !> @date November, 2013 - Initial Version 981 986 !> 982 987 !> @param[in] dd_cutoff cut-off frequency … … 1038 1043 !> 1039 1044 !> @author J.Paul 1040 !> - November, 2013- Initial Version1045 !> @date November, 2013 - Initial Version 1041 1046 !> 1042 1047 !> @param[in] dd_cutoff cut-off frequency … … 1090 1095 !> 1091 1096 !> @author J.Paul 1092 !> - November, 2013- Initial Version1097 !> @date November, 2013 - Initial Version 1093 1098 !> 1094 1099 !> @param[in] dd_cutoff cut-off frequency … … 1146 1151 !> 1147 1152 !> @author J.Paul 1148 !> - November, 2013- Initial Version1153 !> @date November, 2013 - Initial Version 1149 1154 !> 1150 1155 !> @param[in] dd_cutoff cut-off frequency … … 1198 1203 !> 1199 1204 !> @author J.Paul 1200 !> - November, 2013- Initial Version1205 !> @date November, 2013 - Initial Version 1201 1206 !> 1202 1207 !> @param[in] dd_cutoff cut-off frequency -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/function.f90
r5037 r6487 51 51 !> @endcode 52 52 !> 53 !> to check if character is real 54 !> @code 55 !> ll_is_real=fct_is_real(cd_var) 56 !> @endcode 57 !> 53 58 !> to split string into substring and return one of the element:<br/> 54 59 !> @code … … 89 94 ! REVISION HISTORY: 90 95 !> @date November, 2013 - Initial Version 91 !> @date September, 2014 - add header 96 !> @date September, 2014 97 !> - add header 92 98 ! 93 99 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 106 112 PUBLIC :: fct_lower !< convert character from upper to lower case 107 113 PUBLIC :: fct_is_num !< check if character is numeric 114 PUBLIC :: fct_is_real !< check if character is real 108 115 PUBLIC :: fct_split !< split string into substring 109 116 PUBLIC :: fct_basename !< return basename (name without path) … … 153 160 ! 154 161 !> @author J.Paul 155 !> - September, 2014- Initial Version162 !> @date September, 2014 - Initial Version 156 163 ! 157 164 !> @param[in] cd_char string character … … 177 184 ! 178 185 !> @author J.Paul 179 !> - September, 2014- Initial Version186 !> @date September, 2014 - Initial Version 180 187 ! 181 188 !> @param[in] cd_char string character … … 201 208 ! 202 209 !> @author J.Paul 203 !> - Nov, 2013- Initial Version210 !> @date November, 2013 - Initial Version 204 211 ! 205 212 !> @param[in] cd_char string character … … 225 232 ! 226 233 !> @author J.Paul 227 !> - November, 2013- Initial Version234 !> @date November, 2013 - Initial Version 228 235 ! 229 236 !> @param[in] cd_char string character … … 249 256 ! 250 257 !> @author J.Paul 251 !> - November, 2013- Initial Version258 !> @date November, 2013 - Initial Version 252 259 ! 253 260 !> @param[in] cd_char string character … … 273 280 !> 274 281 !> @author J.Paul 275 !> - November, 2013- Initial Version282 !> @date November, 2013 - Initial Version 276 283 !> 277 284 !> @param[in] cd_char string character … … 297 304 !> 298 305 !> @author J.Paul 299 !> - November, 2013- Initial Version306 !> @date November, 2013 - Initial Version 300 307 !> 301 308 !> @param[in] cd_char string character … … 321 328 !> 322 329 !> @author J.Paul 323 !> - November, 2013- Initial Version330 !> @date November, 2013 - Initial Version 324 331 !> 325 332 !> @return file id … … 344 351 ! 345 352 !> @author J.Paul 346 !> - November, 2013- Initial Version353 !> @date November, 2013 - Initial Version 347 354 !> 348 355 !> @param[in] id_status … … 365 372 ! 366 373 !> @author J.Paul 367 !> - November, 2014- Initial Version374 !> @date November, 2014 - Initial Version 368 375 !> 369 376 !> @param[in] cd_msg optional message to be added … … 387 394 !> 388 395 !> @author J.Paul 389 !> - November, 2013- Initial Version396 !> @date November, 2013 - Initial Version 390 397 ! 391 398 !> @param[in] ld_var logical variable … … 409 416 !> 410 417 !> @author J.Paul 411 !> - November, 2013- Initial Version418 !> @date November, 2013 - Initial Version 412 419 ! 413 420 !> @param[in] bd_var integer(1) variable … … 431 438 !> 432 439 !> @author J.Paul 433 !> - November, 2013- Initial Version440 !> @date November, 2013 - Initial Version 434 441 ! 435 442 !> @param[in] sd_var integer(2) variable … … 453 460 !> 454 461 !> @author J.Paul 455 !> - November, 2013- Initial Version462 !> @date November, 2013 - Initial Version 456 463 ! 457 464 !> @param[in] id_var integer(4) variable … … 475 482 !> 476 483 !> @author J.Paul 477 !> - November, 2013- Initial Version484 !> @date November, 2013 - Initial Version 478 485 ! 479 486 !> @param[in] kd_var integer(8) variable … … 497 504 !> 498 505 !> @author J.Paul 499 !> - November, 2013- Initial Version506 !> @date November, 2013 - Initial Version 500 507 ! 501 508 !> @param[in] rd_var real(4) variable … … 519 526 !> 520 527 !> @author J.Paul 521 !> - November, 2013- Initial Version528 !> @date November, 2013 - Initial Version 522 529 ! 523 530 !> @param[in] dd_var real(8) variable … … 544 551 !> 545 552 !> @author J.Paul 546 !> - November, 2013- Initial Version553 !> @date November, 2013 - Initial Version 547 554 ! 548 555 !> @param[in] cd_arr array of character … … 590 597 ! 591 598 !> @author J.Paul 592 !> - November, 2013- Initial Version599 !> @date November, 2013 - Initial Version 593 600 ! 594 601 !> @param[in] cd_var character … … 647 654 ! 648 655 !> @author J.Paul 649 !> - November, 2013- Initial Version656 !> @date November, 2013 - Initial Version 650 657 ! 651 658 !> @param[in] cd_var character … … 697 704 ! 698 705 !> @author J.Paul 699 !> - November, 2013- Initial Version706 !> @date November, 2013 - Initial Version 700 707 ! 701 708 !> @param[in] cd_var character … … 723 730 END FUNCTION fct_is_num 724 731 !------------------------------------------------------------------- 732 !> @brief This function check if character is real number. 733 ! 734 !> @details 735 !> it allows exponantial and decimal number 736 !> exemple : 1e6, 2.3 737 !> 738 !> @author J.Paul 739 !> @date June, 2015 - Initial Version 740 ! 741 !> @param[in] cd_var character 742 !> @return character is numeric 743 !------------------------------------------------------------------- 744 PURE LOGICAL FUNCTION fct_is_real(cd_var) 745 IMPLICIT NONE 746 ! Argument 747 CHARACTER(LEN=*), INTENT(IN) :: cd_var 748 749 ! local variables 750 LOGICAL :: ll_exp 751 LOGICAL :: ll_dec 752 753 ! loop indices 754 INTEGER :: ji 755 !---------------------------------------------------------------- 756 757 ll_exp=.TRUE. 758 ll_dec=.FALSE. 759 DO ji=1,LEN(TRIM(cd_var)) 760 IF( IACHAR(cd_var(ji:ji)) >= IACHAR('0') .AND. & 761 & IACHAR(cd_var(ji:ji)) <= IACHAR('9') )THEN 762 763 fct_is_real=.TRUE. 764 ll_exp=.FALSE. 765 766 ELSEIF( TRIM(cd_var(ji:ji))=='e' )THEN 767 768 IF( ll_exp .OR. ji== LEN(TRIM(cd_var)) )THEN 769 fct_is_real=.FALSE. 770 EXIT 771 ELSE 772 ll_exp=.TRUE. 773 ENDIF 774 775 ELSEIF( TRIM(cd_var(ji:ji))=='.' )THEN 776 777 IF( ll_dec )THEN 778 fct_is_real=.FALSE. 779 EXIT 780 ELSE 781 fct_is_real=.TRUE. 782 ll_dec=.TRUE. 783 ENDIF 784 785 ELSE 786 787 fct_is_real=.FALSE. 788 EXIT 789 790 ENDIF 791 ENDDO 792 793 END FUNCTION fct_is_real 794 !------------------------------------------------------------------- 725 795 !> @brief This function split string of character 726 796 !> using separator character, by default '|', … … 728 798 ! 729 799 !> @author J.Paul 730 !> - November, 2013- Initial Version800 !> @date November, 2013 - Initial Version 731 801 ! 732 802 !> @param[in] cd_string string of character … … 808 878 ! 809 879 !> @author J.Paul 810 !> - November, 2013- Initial Version880 !> @date November, 2013 - Initial Version 811 881 ! 812 882 !> @param[in] cd_string string of character … … 873 943 !> Optionally you could specify another separator. 874 944 !> @author J.Paul 875 !> - November, 2013- Initial Version945 !> @date November, 2013 - Initial Version 876 946 ! 877 947 !> @param[in] cd_string filename … … 914 984 !> Optionally you could specify another separator. 915 985 !> @author J.Paul 916 !> - November, 2013- Initial Version986 !> @date November, 2013 - Initial Version 917 987 ! 918 988 !> @param[in] cd_string filename -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/grid.f90
r5037 r6487 149 149 !> CALL grid_check_coincidence(td_coord0, td_coord1, 150 150 !> id_imin0, id_imax0, id_jmin0, id_jmax0 151 !> [,id_rho])151 !> ,id_rho) 152 152 !> @endcode 153 153 !> - td_coord0 is coarse grid coordinate mpp structure … … 161 161 !> - id_jmax0 is coarse grid upper right corner j-indice of fine grid 162 162 !> domain 163 !> - id_rho is array of refinement factor (default 1)163 !> - id_rho is array of refinement factor 164 164 !> 165 165 !> to add ghost cell at boundaries:<br/> … … 213 213 !> @date October, 2014 214 214 !> - use mpp file structure instead of file 215 !> @date February, 2015 216 !> - add function grid_fill_small_msk to fill small domain inside bigger one 215 217 ! 216 218 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 255 257 PUBLIC :: grid_split_domain !< compute closed sea domain 256 258 PUBLIC :: grid_fill_small_dom !< fill small closed sea with fill value 259 PUBLIC :: grid_fill_small_msk !< fill small domain inside bigger one 257 260 258 261 ! get closest coarse grid indices of fine grid domain … … 352 355 !> @note need all processor files to be there 353 356 !> @author J.Paul 354 !> - October, 2014- Initial Version357 !> @date October, 2014 - Initial Version 355 358 !> 356 359 !> @param[inout] td_file file structure … … 466 469 !> - compute East West overlap 467 470 !> 468 !> @note need all processor files to be there471 !> @note need all processor files 469 472 !> @author J.Paul 470 !> - October, 2014- Initial Version473 !> @date October, 2014 - Initial Version 471 474 !> 472 475 !> @param[in] td_mpp mpp structure … … 496 499 il_ew =-1 497 500 501 CALL logger_info("GRID GET INFO: look for "//TRIM(td_mpp%c_name)) 498 502 ! copy structure 499 503 tl_mpp=mpp_copy(td_mpp) … … 523 527 ENDIF 524 528 529 CALL logger_info("GRID GET INFO: perio "//TRIM(fct_str(il_perio))) 530 525 531 SELECT CASE(il_perio) 526 532 CASE(3,4) 533 il_pivot=1 534 CASE(5,6) 527 535 il_pivot=0 528 CASE(5,6)529 il_pivot=1530 536 CASE(0,1,2) 531 537 il_pivot=1 … … 534 540 IF( il_pivot < 0 .OR. il_pivot > 1 )THEN 535 541 ! get pivot 542 CALL logger_info("GRID GET INFO: look for pivot ") 536 543 il_pivot=grid_get_pivot(tl_mpp) 537 544 ENDIF … … 539 546 IF( il_perio < 0 .OR. il_perio > 6 )THEN 540 547 ! get periodicity 548 CALL logger_info("GRID GET INFO: look for perio ") 541 549 il_perio=grid_get_perio(tl_mpp, il_pivot) 542 550 ENDIF … … 544 552 IF( il_ew < 0 )THEN 545 553 ! get periodicity 554 CALL logger_info("GRID GET INFO: look for overlap ") 546 555 il_ew=grid_get_ew_overlap(tl_mpp) 547 556 ENDIF … … 595 604 !> 596 605 !> @author J.Paul 597 !> - November, 2013- Subroutine written606 !> @date November, 2013 - Initial version 598 607 !> @date September, 2014 599 608 !> - add dummy loop in case variable not over right point. … … 708 717 !> 709 718 !> @author J.Paul 710 !> -October, 2014 - Initial version719 !> @date October, 2014 - Initial version 711 720 ! 712 721 !> @param[in] dd_value array of value … … 783 792 784 793 IF( ll_check )THEN 785 CALL logger_info("GRID GET PIVOT: T-pivot")794 CALL logger_info("GRID GET PIVOT: F-pivot") 786 795 grid__get_pivot_varT=0 787 796 ENDIF … … 801 810 !> 802 811 !> @author J.Paul 803 !> -October, 2014 - Initial version812 !> @date October, 2014 - Initial version 804 813 ! 805 814 !> @param[in] dd_value array of value … … 876 885 877 886 IF( ll_check )THEN 878 CALL logger_info("GRID GET PIVOT: T-pivot")887 CALL logger_info("GRID GET PIVOT: F-pivot") 879 888 grid__get_pivot_varU=0 880 889 ENDIF … … 894 903 !> 895 904 !> @author J.Paul 896 !> -October, 2014 - Initial version905 !> @date October, 2014 - Initial version 897 906 ! 898 907 !> @param[in] dd_value array of value … … 969 978 970 979 IF( ll_check )THEN 971 CALL logger_info("GRID GET PIVOT: T-pivot")980 CALL logger_info("GRID GET PIVOT: F-pivot") 972 981 grid__get_pivot_varV=0 973 982 ENDIF … … 987 996 !> 988 997 !> @author J.Paul 989 !> -October, 2014 - Initial version998 !> @date October, 2014 - Initial version 990 999 ! 991 1000 !> @param[in] dd_value array of value … … 1062 1071 1063 1072 IF( ll_check )THEN 1064 CALL logger_info("GRID GET PIVOT: T-pivot")1073 CALL logger_info("GRID GET PIVOT: F-pivot") 1065 1074 grid__get_pivot_varF=0 1066 1075 ENDIF … … 1083 1092 !> 1084 1093 !> @author J.Paul 1085 !> - Ocotber, 2014- Initial version1094 !> @date Ocotber, 2014 - Initial version 1086 1095 ! 1087 1096 !> @param[in] td_file file structure … … 1172 1181 !> 1173 1182 !> @author J.Paul 1174 !> -October, 2014 - Initial version1183 !> @date October, 2014 - Initial version 1175 1184 ! 1176 1185 !> @param[in] td_mpp mpp file structure … … 1277 1286 !> 1: cyclic east-west boundary 1278 1287 !> 2: symmetric boundary condition across the equator 1279 !> 3: North fold boundary (with a F-point pivot)1280 !> 4: North fold boundary (with a F-point pivot) and cyclic east-west boundary1281 !> 5: North fold boundary (with a T-point pivot)1282 !> 6: North fold boundary (with a T-point pivot) and cyclic east-west boundary1288 !> 3: North fold boundary (with a T-point pivot) 1289 !> 4: North fold boundary (with a T-point pivot) and cyclic east-west boundary 1290 !> 5: North fold boundary (with a F-point pivot) 1291 !> 6: North fold boundary (with a F-point pivot) and cyclic east-west boundary 1283 1292 !> 1284 1293 !> @warning pivot point should have been computed before run this script. see grid_get_pivot. 1285 1294 !> 1286 1295 !> @author J.Paul 1287 !> - November, 2013- Subroutine written1296 !> @date November, 2013 - Initial version 1288 1297 !> @date October, 2014 1289 1298 !> - work on variable structure instead of file structure … … 1452 1461 !> 1453 1462 !> @author J.Paul 1454 !> -October, 2014 - Initial version1463 !> @date October, 2014 - Initial version 1455 1464 !> 1456 1465 !> @param[in] td_file file structure … … 1537 1546 !> 1: cyclic east-west boundary 1538 1547 !> 2: symmetric boundary condition across the equator 1539 !> 3: North fold boundary (with a F-point pivot)1540 !> 4: North fold boundary (with a F-point pivot) and cyclic east-west boundary1541 !> 5: North fold boundary (with a T-point pivot)1542 !> 6: North fold boundary (with a T-point pivot) and cyclic east-west boundary1548 !> 3: North fold boundary (with a T-point pivot) 1549 !> 4: North fold boundary (with a T-point pivot) and cyclic east-west boundary 1550 !> 5: North fold boundary (with a F-point pivot) 1551 !> 6: North fold boundary (with a F-point pivot) and cyclic east-west boundary 1543 1552 !> 1544 1553 !> @warning pivot point should have been computed before run this script. see grid_get_pivot. 1545 1554 !> 1546 1555 !> @author J.Paul 1547 !> -October, 2014 - Initial version1556 !> @date October, 2014 - Initial version 1548 1557 ! 1549 1558 !> @param[in] td_mpp mpp file structure … … 1634 1643 ! 1635 1644 !> @author J.Paul 1636 !> - November, 2013- Initial Version1645 !> @date November, 2013 - Initial Version 1637 1646 !> @date October, 2014 1638 1647 !> - work on mpp file structure instead of file structure … … 1746 1755 !> 1747 1756 !> @author J.Paul 1748 !> - October, 2014- Initial Version1757 !> @date October, 2014 - Initial Version 1749 1758 !> 1750 1759 !> @param[in] td_file file structure … … 1797 1806 ! 1798 1807 !> @author J.Paul 1799 !> - November, 2013- Initial Version1808 !> @date November, 2013 - Initial Version 1800 1809 !> @date October, 2014 1801 1810 !> - work on mpp file structure instead of file structure … … 1853 1862 !> 1854 1863 !> @author J.Paul 1855 !> - November, 2013- Initial Version1864 !> @date November, 2013 - Initial Version 1856 1865 !> 1857 1866 !> @param[in] td_lat latitude variable structure … … 1890 1899 ! 1891 1900 !> @author J.Paul 1892 !> - November, 2013- Initial Version1901 !> @date November, 2013 - Initial Version 1893 1902 !> @date October, 2014 1894 1903 !> - work on mpp file structure instead of file structure … … 1978 1987 !> 1979 1988 !> @author J.Paul 1980 !> - November, 2013- Initial Version1989 !> @date November, 2013 - Initial Version 1981 1990 !> @date September, 2014 1982 1991 !> - use grid point to read coordinates variable. 1983 1992 !> @date October, 2014 1984 1993 !> - work on mpp file structure instead of file structure 1994 !> @date February, 2015 1995 !> - use longitude or latitude as standard name, if can not find 1996 !> longitude_T, latitude_T... 1985 1997 !> 1986 1998 !> @param[in] td_coord0 coarse grid coordinate mpp structure … … 2004 2016 2005 2017 ! local variable 2006 TYPE(TMPP) :: tl_coord0 2007 TYPE(TMPP) :: tl_coord1 2008 2009 TYPE(TVAR) :: tl_lon0 2010 TYPE(TVAR) :: tl_lat0 2011 TYPE(TVAR) :: tl_lon1 2012 TYPE(TVAR) :: tl_lat1 2013 2014 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho 2015 2016 INTEGER(i4), DIMENSION(2,2) :: il_xghost0 2017 INTEGER(i4), DIMENSION(2,2) :: il_xghost1 2018 2019 INTEGER(i4) :: il_imin0 2020 INTEGER(i4) :: il_imax0 2021 INTEGER(i4) :: il_jmin0 2022 INTEGER(i4) :: il_jmax0 2023 2024 CHARACTER(LEN= 1) :: cl_point 2025 CHARACTER(LEN=lc) :: cl_name 2018 CHARACTER(LEN= 1) :: cl_point 2019 CHARACTER(LEN=lc) :: cl_name 2020 2021 INTEGER(i4) :: il_imin0 2022 INTEGER(i4) :: il_imax0 2023 INTEGER(i4) :: il_jmin0 2024 INTEGER(i4) :: il_jmax0 2025 INTEGER(i4) :: il_ind 2026 2027 INTEGER(i4), DIMENSION(2,2) :: il_xghost0 2028 INTEGER(i4), DIMENSION(2,2) :: il_xghost1 2029 2030 INTEGER(i4), DIMENSION(:) , ALLOCATABLE :: il_rho 2031 2032 TYPE(TVAR) :: tl_lon0 2033 TYPE(TVAR) :: tl_lat0 2034 TYPE(TVAR) :: tl_lon1 2035 TYPE(TVAR) :: tl_lat1 2036 2037 TYPE(TMPP) :: tl_coord0 2038 TYPE(TMPP) :: tl_coord1 2026 2039 2027 2040 ! loop indices … … 2057 2070 ! read coarse longitue and latitude 2058 2071 WRITE(cl_name,*) 'longitude_'//TRIM(cl_point) 2072 il_ind=var_get_id(tl_coord0%t_proc(1)%t_var(:), cl_name) 2073 IF( il_ind == 0 )THEN 2074 CALL logger_warn("GRID GET COARSE INDEX: no variable "//& 2075 & TRIM(cl_name)//" in file "//TRIM(tl_coord0%c_name)//". & 2076 & try to use longitude.") 2077 WRITE(cl_name,*) 'longitude' 2078 ENDIF 2059 2079 tl_lon0=iom_mpp_read_var(tl_coord0, TRIM(cl_name)) 2080 2060 2081 WRITE(cl_name,*) 'latitude_'//TRIM(cl_point) 2082 il_ind=var_get_id(tl_coord0%t_proc(1)%t_var(:), cl_name) 2083 IF( il_ind == 0 )THEN 2084 CALL logger_warn("GRID GET COARSE INDEX: no variable "//& 2085 & TRIM(cl_name)//" in file "//TRIM(tl_coord0%c_name)//". & 2086 & try to use latitude.") 2087 WRITE(cl_name,*) 'latitude' 2088 ENDIF 2061 2089 tl_lat0=iom_mpp_read_var(tl_coord0, TRIM(cl_name)) 2062 2090 … … 2077 2105 ! read fine longitue and latitude 2078 2106 WRITE(cl_name,*) 'longitude_'//TRIM(cl_point) 2107 il_ind=var_get_id(tl_coord1%t_proc(1)%t_var(:), cl_name) 2108 IF( il_ind == 0 )THEN 2109 CALL logger_warn("GRID GET COARSE INDEX: no variable "//& 2110 & TRIM(cl_name)//" in file "//TRIM(tl_coord1%c_name)//". & 2111 & try to use longitude.") 2112 WRITE(cl_name,*) 'longitude' 2113 ENDIF 2079 2114 tl_lon1=iom_mpp_read_var(tl_coord1, TRIM(cl_name)) 2115 2080 2116 WRITE(cl_name,*) 'latitude_'//TRIM(cl_point) 2117 il_ind=var_get_id(tl_coord1%t_proc(1)%t_var(:), cl_name) 2118 IF( il_ind == 0 )THEN 2119 CALL logger_warn("GRID GET COARSE INDEX: no variable "//& 2120 & TRIM(cl_name)//" in file "//TRIM(tl_coord1%c_name)//". & 2121 & try to use latitude.") 2122 WRITE(cl_name,*) 'latitude' 2123 ENDIF 2081 2124 tl_lat1=iom_mpp_read_var(tl_coord1, TRIM(cl_name)) 2082 2125 … … 2127 2170 !> 2128 2171 !> @author J.Paul 2129 !> - November, 2013- Initial Version2172 !> @date November, 2013 - Initial Version 2130 2173 !> @date September, 2014 2131 2174 !> - use grid point to read coordinates variable. 2132 2175 !> @date October, 2014 2133 2176 !> - work on mpp file structure instead of file structure 2177 !> @date February, 2015 2178 !> - use longitude or latitude as standard name, if can not find 2179 !> longitude_T, latitude_T... 2134 2180 !> 2135 2181 !> @param[in] td_longitude0 coarse grid longitude … … 2154 2200 2155 2201 ! local variable 2156 TYPE(TMPP) :: tl_coord1 2157 2158 TYPE(TVAR) :: tl_lon1 2159 TYPE(TVAR) :: tl_lat1 2160 2161 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho 2162 2163 INTEGER(i4), DIMENSION(2,2) :: il_xghost 2164 2165 CHARACTER(LEN= 1) :: cl_point 2166 CHARACTER(LEN=lc) :: cl_name 2202 CHARACTER(LEN= 1) :: cl_point 2203 CHARACTER(LEN=lc) :: cl_name 2204 2205 INTEGER(i4) :: il_ind 2206 2207 INTEGER(i4), DIMENSION(:) , ALLOCATABLE :: il_rho 2208 2209 INTEGER(i4), DIMENSION(2,2) :: il_xghost 2210 2211 TYPE(TVAR) :: tl_lon1 2212 TYPE(TVAR) :: tl_lat1 2213 2214 TYPE(TMPP) :: tl_coord1 2167 2215 2168 2216 ! loop indices … … 2209 2257 ! read fine longitue and latitude 2210 2258 WRITE(cl_name,*) 'longitude_'//TRIM(cl_point) 2259 il_ind=var_get_id(tl_coord1%t_proc(1)%t_var(:), cl_name) 2260 IF( il_ind == 0 )THEN 2261 CALL logger_warn("GRID GET COARSE INDEX: no variable "//& 2262 & TRIM(cl_name)//"in file "//TRIM(tl_coord1%c_name)//". & 2263 & try to use longitude.") 2264 WRITE(cl_name,*) 'longitude' 2265 ENDIF 2211 2266 tl_lon1=iom_mpp_read_var(tl_coord1, TRIM(cl_name)) 2267 2212 2268 WRITE(cl_name,*) 'latitude_'//TRIM(cl_point) 2269 il_ind=var_get_id(tl_coord1%t_proc(1)%t_var(:), cl_name) 2270 IF( il_ind == 0 )THEN 2271 CALL logger_warn("GRID GET COARSE INDEX: no variable "//& 2272 & TRIM(cl_name)//"in file "//TRIM(tl_coord1%c_name)//". & 2273 & try to use longitude.") 2274 WRITE(cl_name,*) 'latitude' 2275 ENDIF 2213 2276 tl_lat1=iom_mpp_read_var(tl_coord1, TRIM(cl_name)) 2214 2277 … … 2244 2307 !> 2245 2308 !> @author J.Paul 2246 !> - November, 2013- Initial Version2309 !> @date November, 2013 - Initial Version 2247 2310 !> @date September, 2014 2248 2311 !> - use grid point to read coordinates variable. 2249 2312 !> @date October, 2014 2250 2313 !> - work on mpp file structure instead of file structure 2314 !> @date February, 2015 2315 !> - use longitude or latitude as standard name, if can not find 2316 !> longitude_T, latitude_T... 2251 2317 !> 2252 2318 !> @param[in] td_coord0 coarse grid coordinate mpp structure … … 2271 2337 2272 2338 ! local variable 2273 TYPE(TMPP) :: tl_coord0 2274 2275 TYPE(TVAR) :: tl_lon0 2276 TYPE(TVAR) :: tl_lat0 2277 2278 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho 2279 2280 INTEGER(i4), DIMENSION(2,2) :: il_xghost 2281 2282 INTEGER(i4) :: il_imin0 2283 INTEGER(i4) :: il_imax0 2284 INTEGER(i4) :: il_jmin0 2285 INTEGER(i4) :: il_jmax0 2286 2287 CHARACTER(LEN= 1) :: cl_point 2288 CHARACTER(LEN=lc) :: cl_name 2339 CHARACTER(LEN= 1) :: cl_point 2340 CHARACTER(LEN=lc) :: cl_name 2341 2342 INTEGER(i4) :: il_imin0 2343 INTEGER(i4) :: il_imax0 2344 INTEGER(i4) :: il_jmin0 2345 INTEGER(i4) :: il_jmax0 2346 INTEGER(i4) :: il_ind 2347 2348 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho 2349 2350 INTEGER(i4), DIMENSION(2,2) :: il_xghost 2351 2352 TYPE(TVAR) :: tl_lon0 2353 TYPE(TVAR) :: tl_lat0 2354 2355 TYPE(TMPP) :: tl_coord0 2289 2356 2290 2357 ! loop indices … … 2330 2397 ! read coarse longitue and latitude 2331 2398 WRITE(cl_name,*) 'longitude_'//TRIM(cl_point) 2399 il_ind=var_get_id(tl_coord0%t_proc(1)%t_var(:), cl_name) 2400 IF( il_ind == 0 )THEN 2401 CALL logger_warn("GRID GET COARSE INDEX: no variable "//& 2402 & TRIM(cl_name)//"in file "//TRIM(tl_coord0%c_name)//". & 2403 & try to use longitude.") 2404 WRITE(cl_name,*) 'longitude' 2405 ENDIF 2332 2406 tl_lon0=iom_mpp_read_var(tl_coord0, TRIM(cl_name)) 2407 2333 2408 WRITE(cl_name,*) 'latitude_'//TRIM(cl_point) 2409 il_ind=var_get_id(tl_coord0%t_proc(1)%t_var(:), cl_name) 2410 IF( il_ind == 0 )THEN 2411 CALL logger_warn("GRID GET COARSE INDEX: no variable "//& 2412 & TRIM(cl_name)//"in file "//TRIM(tl_coord0%c_name)//". & 2413 & try to use latitude.") 2414 WRITE(cl_name,*) 'latitude' 2415 ENDIF 2334 2416 tl_lat0=iom_mpp_read_var(tl_coord0, TRIM(cl_name)) 2335 2417 … … 2377 2459 !> 2378 2460 !> @author J.Paul 2379 !> - November, 2013- Initial Version2461 !> @date November, 2013 - Initial Version 2380 2462 !> @date September, 2014 2381 2463 !> - check grid point … … 2520 2602 CALL grid_del_ghost(tl_lon0, il_xghost0(:,:)) 2521 2603 CALL grid_del_ghost(tl_lat0, il_xghost0(:,:)) 2522 2604 2523 2605 ! "global" coarse grid indice 2524 2606 il_imin0=1 … … 2568 2650 IF( dl_lon1_ll == tl_lon1%d_fill .OR. & 2569 2651 & dl_lat1_ll == tl_lat1%d_fill )THEN 2652 CALL logger_debug("GRID GET COARSE INDEX: lon "//& 2653 & TRIM(fct_str(dl_lon1_ll))//" "//& 2654 & TRIM(fct_str(tl_lon1%d_fill)) ) 2655 CALL logger_debug("GRID GET COARSE INDEX: lat "//& 2656 & TRIM(fct_str(dl_lat1_ll))//" "//& 2657 & TRIM(fct_str(tl_lat1%d_fill)) ) 2570 2658 CALL logger_error("GRID GET COARSE INDEX: lower left corner "//& 2571 2659 & "point is FillValue. remove ghost cell "//& … … 2632 2720 ji = il_iul(1) 2633 2721 jj = il_iul(2) 2634 2635 2722 IF( ABS(tl_lon0%d_value(ji,jj,1,1)-dl_lon1_ul) > dp_delta )THEN 2636 2723 IF(tl_lon0%d_value(ji,jj,1,1) > dl_lon1_ul )THEN … … 2647 2734 ENDIF 2648 2735 ENDIF 2649 2650 2736 IF( ABS(tl_lat0%d_value(ji,jj,1,1)-dl_lat1_ul) > dp_delta )THEN 2651 2737 IF(tl_lat0%d_value(ji,jj,1,1) < dl_lat1_ul )THEN … … 2798 2884 ! 2799 2885 !> @author J.Paul 2800 !> - November, 2013- Initial Version2886 !> @date November, 2013 - Initial Version 2801 2887 ! 2802 2888 !> @param[in] td_lon longitude structure … … 2866 2952 !> 2867 2953 !> @author J.Paul 2868 !> - November, 2013- Initial Version 2954 !> @date November, 2013 - Initial Version 2955 !> @date February, 2015 - change dichotomy method to manage ORCA grid 2869 2956 ! 2870 2957 !> @param[in] dd_lon0 coarse grid array of longitude … … 2872 2959 !> @param[in] dd_lon1 fine grid longitude 2873 2960 !> @param[in] dd_lat1 fine grid latitude 2961 !> @param[in] dd_fill fill value 2874 2962 !> @return coarse grid indices of closest point of fine grid point 2875 !> 2876 !------------------------------------------------------------------- 2877 FUNCTION grid_get_closest( dd_lon0, dd_lat0, dd_lon1, dd_lat1 ) 2963 !------------------------------------------------------------------- 2964 FUNCTION grid_get_closest( dd_lon0, dd_lat0, dd_lon1, dd_lat1, dd_fill ) 2878 2965 IMPLICIT NONE 2879 2966 ! Argument … … 2882 2969 REAL(dp), INTENT(IN) :: dd_lon1 2883 2970 REAL(dp), INTENT(IN) :: dd_lat1 2971 REAL(dp), INTENT(IN), OPTIONAL :: dd_fill 2884 2972 2885 2973 ! function … … 2929 3017 2930 3018 ll_north=.FALSE. 2931 ll_continue=.TRUE. 2932 2933 ! look for meridian 0°/360° 2934 il_jmid = il_jinf + INT(il_shape(2)/2) 2935 il_ind(:) = MAXLOC( dl_lon0(:,il_jmid), dl_lon0(:,il_jmid) <= 360._dp ) 2936 2937 il_imid=il_ind(1) 2938 2939 IF( dl_lon1 == dl_lon0(il_imid,il_jmid) .AND. & 2940 & dd_lat1 == dd_lat0(il_imid,il_jmid) )THEN 2941 2942 il_iinf = il_imid ; il_isup = il_imid 2943 il_jinf = il_jmid ; il_jsup = il_jmid 2944 2945 ll_continue=.FALSE. 2946 2947 ELSE 2948 IF( dl_lon1 < dl_lon0(il_isup,il_jmid) .AND. & 2949 & il_imid /= il_isup )THEN 2950 2951 ! point east 2952 il_iinf = il_imid 2953 2954 ELSE IF( dl_lon1 > dl_lon0(il_iinf,il_jmid) .AND. & 2955 & il_imid /= il_iinf )THEN 2956 2957 ! point west 2958 il_isup = il_imid 2959 2960 ENDIF 3019 ll_continue=.FALSE. 3020 3021 ! avoid to use fillvalue for reduce domain on first time 3022 IF( PRESENT(dd_fill) )THEN 3023 DO WHILE( ALL(dl_lon0(il_isup,:) == dd_fill) ) 3024 il_isup=il_isup-1 3025 ENDDO 3026 DO WHILE( ALL(dl_lon0(il_iinf,:) == dd_fill) ) 3027 il_iinf=il_iinf+1 3028 ENDDO 3029 DO WHILE( ALL(dd_lat0(:,il_jsup) == dd_fill) ) 3030 il_jsup=il_jsup-1 3031 ENDDO 3032 DO WHILE( ALL(dd_lat0(:,il_jinf) == dd_fill) ) 3033 il_jinf=il_jinf+1 3034 ENDDO 2961 3035 2962 3036 il_shape(1)= il_isup - il_iinf + 1 2963 3037 il_shape(2)= il_jsup - il_jinf + 1 2964 3038 2965 il_imid = il_iinf + INT(il_shape(1)/2) 3039 ENDIF 3040 3041 ! special case for north ORCA grid 3042 IF( dd_lat1 > 19. .AND. dl_lon1 < 74. )THEN 3043 ll_north=.TRUE. 3044 ENDIF 3045 3046 IF( .NOT. ll_north )THEN 3047 ! look for meridian 0°/360° 2966 3048 il_jmid = il_jinf + INT(il_shape(2)/2) 2967 2968 ! exit if too close from north fold (safer) 2969 IF( dd_lat0(il_imid,il_jmid) > 50.0 ) ll_north=.TRUE. 2970 2971 ! exit when close enough of point 2972 IF( ANY(il_shape(:) < 10 ) ) ll_continue=.FALSE. 3049 il_ind(:) = MAXLOC( dl_lon0(il_iinf:il_isup,il_jmid), & 3050 & dl_lon0(il_iinf:il_isup,il_jmid) <= 360._dp ) 3051 3052 il_imid=il_ind(1) 3053 3054 IF( dl_lon1 == dl_lon0(il_imid,il_jmid) .AND. & 3055 & dd_lat1 == dd_lat0(il_imid,il_jmid) )THEN 3056 3057 il_iinf = il_imid ; il_isup = il_imid 3058 il_jinf = il_jmid ; il_jsup = il_jmid 3059 3060 ELSE 3061 IF( ALL(dl_lon0(il_isup,il_jinf:il_jsup) > dl_lon1 ) .AND. & 3062 & il_imid /= il_isup )THEN 3063 ! 0 < lon1 < lon0(isup) 3064 ! point east 3065 il_iinf = il_imid+1 3066 ll_continue=.TRUE. 3067 3068 ELSE IF( ALL(dl_lon0(il_iinf,il_jinf:il_jsup) < dl_lon1 ) .AND. & 3069 & il_imid /= il_iinf )THEN 3070 ! lon0(iinf) < lon1 < 360 3071 ! point west 3072 il_isup = il_imid 3073 ll_continue=.TRUE. 3074 3075 ENDIF 3076 3077 il_shape(1)= il_isup - il_iinf + 1 3078 il_shape(2)= il_jsup - il_jinf + 1 3079 3080 il_imid = il_iinf + INT(il_shape(1)/2) 3081 il_jmid = il_jinf + INT(il_shape(2)/2) 3082 3083 ! exit when close enough of point 3084 IF( ANY(il_shape(:) < 10 ) ) ll_continue=.FALSE. 3085 ENDIF 2973 3086 ENDIF 2974 3087 … … 2976 3089 DO WHILE( ll_continue .AND. .NOT. ll_north ) 2977 3090 3091 ll_continue=.FALSE. 2978 3092 IF( dl_lon1 == dl_lon0(il_imid,il_jmid) .AND. & 2979 3093 & dd_lat1 == dd_lat0(il_imid,il_jmid) )THEN … … 2982 3096 il_jinf = il_jmid ; il_jsup = il_jmid 2983 3097 2984 ll_continue=.FALSE.2985 2986 3098 ELSE 2987 IF( dl_lon1 > dl_lon0(il_imid,il_jmid) )THEN3099 IF( ALL(dl_lon0(il_imid,il_jinf:il_jsup) < dl_lon1) )THEN 2988 3100 2989 3101 ! point east 2990 3102 il_iinf = il_imid 3103 ll_continue=.TRUE. 2991 3104 2992 ELSE IF( dl_lon1 < dl_lon0(il_imid,il_jmid) )THEN3105 ELSE IF( ALL(dl_lon0(il_imid,il_jinf:il_jsup) > dl_lon1) )THEN 2993 3106 2994 3107 ! point west 2995 3108 il_isup = il_imid 3109 ll_continue=.TRUE. 2996 3110 2997 3111 ENDIF 2998 3112 2999 IF( dd_lat1 > dd_lat0(il_imid,il_jmid) )THEN3113 IF( ALL(dd_lat0(il_iinf:il_isup,il_jmid) < dd_lat1) )THEN 3000 3114 3001 3115 ! point north 3002 3116 il_jinf = il_jmid 3003 3004 ELSE IF(dd_lat1 < dd_lat0(il_imid,il_jmid) )THEN 3117 ll_continue=.TRUE. 3118 3119 ELSE IF( ALL(dd_lat0(il_iinf:il_isup,il_jmid) > dd_lat1) )THEN 3005 3120 3006 3121 ! point south 3007 3122 il_jsup = il_jmid 3123 ll_continue=.TRUE. 3008 3124 3009 3125 ENDIF … … 3014 3130 il_imid = il_iinf + INT(il_shape(1)/2) 3015 3131 il_jmid = il_jinf + INT(il_shape(2)/2) 3016 3017 ! exit if too close from north fold (safer)3018 IF( dd_lat0(il_imid,il_jmid) > 50.0 ) ll_north=.TRUE.3019 3132 3020 3133 ! exit when close enough of point … … 3049 3162 ! 3050 3163 !> @author J.Paul 3051 !> - November, 2013- Initial Version3164 !> @date November, 2013 - Initial Version 3052 3165 ! 3053 3166 !> @param[in] dd_lon grid longitude array … … 3055 3168 !> @param[in] dd_lonA longitude of point A 3056 3169 !> @param[in] dd_latA latitude of point A 3170 !> @param[in] dd_fill 3057 3171 !> @return array of distance between point A and grid points. 3058 3172 !------------------------------------------------------------------- 3059 FUNCTION grid_distance(dd_lon, dd_lat, dd_lonA, dd_latA )3173 FUNCTION grid_distance(dd_lon, dd_lat, dd_lonA, dd_latA ) 3060 3174 IMPLICIT NONE 3061 3175 ! Argument … … 3110 3224 DO ji=1,il_shape(1) 3111 3225 IF( dl_lon(ji,jj) == dl_lonA .AND. & 3112 & dl_lat(ji,jj) == dl_la TA )THEN3226 & dl_lat(ji,jj) == dl_latA )THEN 3113 3227 grid_distance(ji,jj)=0.0 3114 3228 ELSE 3115 3229 dl_tmp= SIN(dl_latA)*SIN(dl_lat(ji,jj)) + & 3116 & COS(dl_latA)*COS(dl_lat(ji,jj))*COS(dl_lon(ji,jj)-dl_lonA) 3230 & COS(dl_latA)*COS(dl_lat(ji,jj)) * & 3231 & COS(dl_lon(ji,jj)-dl_lonA) 3117 3232 ! check to avoid mistake with ACOS 3118 3233 IF( dl_tmp < -1.0 ) dl_tmp = -1.0 … … 3136 3251 ! 3137 3252 !> @author J.Paul 3138 !> - September, 2014- Initial Version3253 !> @date September, 2014 - Initial Version 3139 3254 !> @date October, 2014 3140 3255 !> - work on mpp file structure instead of file structure … … 3170 3285 3171 3286 ! local variable 3172 INTEGER(i4) :: il_imin0 3173 INTEGER(i4) :: il_jmin0 3174 INTEGER(i4) :: il_imax0 3175 INTEGER(i4) :: il_jmax0 3287 INTEGER(i4) :: il_imin0 3288 INTEGER(i4) :: il_jmin0 3289 INTEGER(i4) :: il_imax0 3290 INTEGER(i4) :: il_jmax0 3291 INTEGER(i4) :: il_ind 3176 3292 3177 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho3293 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho 3178 3294 3179 INTEGER(i4), DIMENSION(2,2) :: il_xghost03180 INTEGER(i4), DIMENSION(2,2) :: il_xghost13181 3182 CHARACTER(LEN= 1) :: cl_point3183 CHARACTER(LEN=lc) :: cl_name3295 INTEGER(i4), DIMENSION(2,2) :: il_xghost0 3296 INTEGER(i4), DIMENSION(2,2) :: il_xghost1 3297 3298 CHARACTER(LEN= 1) :: cl_point 3299 CHARACTER(LEN=lc) :: cl_name 3184 3300 3185 3301 REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lon0 … … 3188 3304 REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lat1 3189 3305 3190 TYPE(TVAR) :: tl_lon03191 TYPE(TVAR) :: tl_lat03192 TYPE(TVAR) :: tl_lon13193 TYPE(TVAR) :: tl_lat13194 3195 TYPE(TMPP) :: tl_coord03196 TYPE(TMPP) :: tl_coord13306 TYPE(TVAR) :: tl_lon0 3307 TYPE(TVAR) :: tl_lat0 3308 TYPE(TVAR) :: tl_lon1 3309 TYPE(TVAR) :: tl_lat1 3310 3311 TYPE(TMPP) :: tl_coord0 3312 TYPE(TMPP) :: tl_coord1 3197 3313 3198 3314 ! loop indices … … 3227 3343 ! read coarse longitue and latitude 3228 3344 WRITE(cl_name,*) 'longitude_'//TRIM(cl_point) 3345 il_ind=var_get_id(tl_coord0%t_proc(1)%t_var(:), cl_name) 3346 IF( il_ind == 0 )THEN 3347 CALL logger_warn("GRID GET FINE OFFSET: no variable "//& 3348 & TRIM(cl_name)//" in file "//TRIM(tl_coord0%c_name)//". & 3349 & try to use longitude.") 3350 WRITE(cl_name,*) 'longitude' 3351 ENDIF 3229 3352 tl_lon0=iom_mpp_read_var(tl_coord0, TRIM(cl_name)) 3353 3230 3354 WRITE(cl_name,*) 'latitude_'//TRIM(cl_point) 3355 il_ind=var_get_id(tl_coord0%t_proc(1)%t_var(:), cl_name) 3356 IF( il_ind == 0 )THEN 3357 CALL logger_warn("GRID GET FINE OFFSET: no variable "//& 3358 & TRIM(cl_name)//" in file "//TRIM(tl_coord0%c_name)//". & 3359 & try to use latitude.") 3360 WRITE(cl_name,*) 'latitude' 3361 ENDIF 3231 3362 tl_lat0=iom_mpp_read_var(tl_coord0, TRIM(cl_name)) 3232 3363 … … 3267 3398 ! read fine longitue and latitude 3268 3399 WRITE(cl_name,*) 'longitude_'//TRIM(cl_point) 3400 il_ind=var_get_id(tl_coord1%t_proc(1)%t_var(:), cl_name) 3401 IF( il_ind == 0 )THEN 3402 CALL logger_warn("GRID GET FINE OFFSET: no variable "//& 3403 & TRIM(cl_name)//" in file "//TRIM(tl_coord1%c_name)//". & 3404 & try to use longitude.") 3405 WRITE(cl_name,*) 'longitude' 3406 ENDIF 3269 3407 tl_lon1=iom_mpp_read_var(tl_coord1, TRIM(cl_name)) 3408 3270 3409 WRITE(cl_name,*) 'latitude_'//TRIM(cl_point) 3410 il_ind=var_get_id(tl_coord1%t_proc(1)%t_var(:), cl_name) 3411 IF( il_ind == 0 )THEN 3412 CALL logger_warn("GRID GET FINE OFFSET: no variable "//& 3413 & TRIM(cl_name)//" in file "//TRIM(tl_coord1%c_name)//". & 3414 & try to use latitude.") 3415 WRITE(cl_name,*) 'latitude' 3416 ENDIF 3271 3417 tl_lat1=iom_mpp_read_var(tl_coord1, TRIM(cl_name)) 3272 3418 … … 3318 3464 ! 3319 3465 !> @author J.Paul 3320 !> - September, 2014- Initial Version3466 !> @date September, 2014 - Initial Version 3321 3467 !> @date October, 2014 3322 3468 !> - work on mpp file structure instead of file structure … … 3354 3500 3355 3501 ! local variable 3356 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho 3502 INTEGER(i4) :: il_ind 3503 INTEGER(i4), DIMENSION(2,2) :: il_xghost1 3504 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho 3357 3505 3358 INTEGER(i4), DIMENSION(2,2) :: il_xghost1 3359 3360 CHARACTER(LEN= 1) :: cl_point 3361 CHARACTER(LEN=lc) :: cl_name 3506 CHARACTER(LEN= 1) :: cl_point 3507 CHARACTER(LEN=lc) :: cl_name 3362 3508 3363 3509 REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lon1 3364 3510 REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lat1 3365 3511 3366 TYPE(TVAR) :: tl_lon13367 TYPE(TVAR) :: tl_lat13368 3369 TYPE(TMPP) :: tl_coord13512 TYPE(TVAR) :: tl_lon1 3513 TYPE(TVAR) :: tl_lat1 3514 3515 TYPE(TMPP) :: tl_coord1 3370 3516 ! loop indices 3371 3517 !---------------------------------------------------------------- … … 3397 3543 ! read fine longitue and latitude 3398 3544 WRITE(cl_name,*) 'longitude_'//TRIM(cl_point) 3545 il_ind=var_get_id(tl_coord1%t_proc(1)%t_var(:), cl_name) 3546 IF( il_ind == 0 )THEN 3547 CALL logger_warn("GRID GET FINE OFFSET: no variable "//& 3548 & TRIM(cl_name)//" in file "//TRIM(tl_coord1%c_name)//". & 3549 & try to use longitude.") 3550 WRITE(cl_name,*) 'longitude' 3551 ENDIF 3399 3552 tl_lon1=iom_mpp_read_var(tl_coord1, TRIM(cl_name)) 3553 3400 3554 WRITE(cl_name,*) 'latitude_'//TRIM(cl_point) 3555 il_ind=var_get_id(tl_coord1%t_proc(1)%t_var(:), cl_name) 3556 IF( il_ind == 0 )THEN 3557 CALL logger_warn("GRID GET FINE OFFSET: no variable "//& 3558 & TRIM(cl_name)//" in file "//TRIM(tl_coord1%c_name)//". & 3559 & try to use latitude.") 3560 WRITE(cl_name,*) 'latitude' 3561 ENDIF 3401 3562 tl_lat1=iom_mpp_read_var(tl_coord1, TRIM(cl_name)) 3402 3563 … … 3446 3607 ! 3447 3608 !> @author J.Paul 3448 !> - September, 2014- Initial Version3609 !> @date September, 2014 - Initial Version 3449 3610 !> @date October, 2014 3450 3611 !> - work on mpp file structure instead of file structure … … 3483 3644 3484 3645 ! local variable 3485 INTEGER(i4) :: il_imin0 3486 INTEGER(i4) :: il_jmin0 3487 INTEGER(i4) :: il_imax0 3488 INTEGER(i4) :: il_jmax0 3646 INTEGER(i4) :: il_imin0 3647 INTEGER(i4) :: il_jmin0 3648 INTEGER(i4) :: il_imax0 3649 INTEGER(i4) :: il_jmax0 3650 INTEGER(i4) :: il_ind 3489 3651 3490 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho3652 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho 3491 3653 3492 INTEGER(i4), DIMENSION(2,2) :: il_xghost03493 3494 CHARACTER(LEN= 1) :: cl_point3495 CHARACTER(LEN=lc) :: cl_name3654 INTEGER(i4), DIMENSION(2,2) :: il_xghost0 3655 3656 CHARACTER(LEN= 1) :: cl_point 3657 CHARACTER(LEN=lc) :: cl_name 3496 3658 3497 3659 REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lon0 3498 3660 REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lat0 3499 3661 3500 TYPE(TVAR) :: tl_lon03501 TYPE(TVAR) :: tl_lat03502 3503 TYPE(TMPP) :: tl_coord03662 TYPE(TVAR) :: tl_lon0 3663 TYPE(TVAR) :: tl_lat0 3664 3665 TYPE(TMPP) :: tl_coord0 3504 3666 ! loop indices 3505 3667 !---------------------------------------------------------------- … … 3530 3692 ! read coarse longitue and latitude 3531 3693 WRITE(cl_name,*) 'longitude_'//TRIM(cl_point) 3694 il_ind=var_get_id(tl_coord0%t_proc(1)%t_var(:), cl_name) 3695 IF( il_ind == 0 )THEN 3696 CALL logger_warn("GRID GET FINE OFFSET: no variable "//& 3697 & TRIM(cl_name)//" in file "//TRIM(tl_coord0%c_name)//". & 3698 & try to use longitude.") 3699 WRITE(cl_name,*) 'longitude' 3700 ENDIF 3532 3701 tl_lon0=iom_mpp_read_var(tl_coord0, TRIM(cl_name)) 3702 3533 3703 WRITE(cl_name,*) 'latitude_'//TRIM(cl_point) 3704 il_ind=var_get_id(tl_coord0%t_proc(1)%t_var(:), cl_name) 3705 IF( il_ind == 0 )THEN 3706 CALL logger_warn("GRID GET FINE OFFSET: no variable "//& 3707 & TRIM(cl_name)//" in file "//TRIM(tl_coord0%c_name)//". & 3708 & try to use latitude.") 3709 WRITE(cl_name,*) 'latitude' 3710 ENDIF 3534 3711 tl_lat0=iom_mpp_read_var(tl_coord0, TRIM(cl_name)) 3535 3712 … … 3585 3762 ! 3586 3763 !> @author J.Paul 3587 !> - November, 2013 - Initial Version 3588 !> @date September, 2014 - rename from grid_get_fine_offset 3589 ! 3764 !> @date November, 2013 - Initial Version 3765 !> @date September, 2014 3766 !> - rename from grid_get_fine_offset 3767 !> @date May, 2015 3768 !> - improve way to find offset 3769 !> 3590 3770 !> @param[in] dd_lon0 coarse grid longitude array 3591 3771 !> @param[in] dd_lat0 coarse grid latitude array … … 3620 3800 3621 3801 ! local variable 3622 INTEGER(i4), DIMENSION(2) :: il_shape0 3623 INTEGER(i4), DIMENSION(2) :: il_shape1 3802 INTEGER(i4), DIMENSION(2) :: il_shape0 3803 INTEGER(i4), DIMENSION(2) :: il_shape1 3804 3624 3805 REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lon0 3625 3806 REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lon1 3807 3808 LOGICAL :: ll_ii 3809 LOGICAL :: ll_ij 3626 3810 3627 3811 ! loop indices … … 3657 3841 grid__get_fine_offset_cc(:,:)=-1 3658 3842 3659 IF( il_shape1(1) > 1 )THEN 3660 3661 ! look for i-direction left offset 3843 IF( il_shape1(jp_J) == 1 )THEN 3844 3845 grid__get_fine_offset_cc(jp_J,:)=((id_rho(jp_J)-1)/2) 3846 3847 ! work on i-direction 3848 ! look for i-direction left offset 3662 3849 IF( dl_lon1(1,1) < dl_lon0(id_imin0+1,id_jmin0) )THEN 3663 3850 DO ji=1,id_rho(jp_I)+2 3664 3851 IF( dl_lon1(ji,1) > dl_lon0(id_imin0+1,id_jmin0) - dp_delta )THEN 3665 grid__get_fine_offset_cc( 1,1)=(id_rho(jp_I)+1)-ji3852 grid__get_fine_offset_cc(jp_I,1)=(id_rho(jp_I)+1)-ji 3666 3853 EXIT 3667 3854 ENDIF … … 3671 3858 & " not match fine grid lower left corner.") 3672 3859 ENDIF 3673 3674 3860 ! look for i-direction right offset 3675 IF( dl_lon1(il_shape1( 1),1) > dl_lon0(id_imax0-1,id_jmin0) )THEN3861 IF( dl_lon1(il_shape1(jp_I),1) > dl_lon0(id_imax0-1,id_jmin0) )THEN 3676 3862 DO ji=1,id_rho(jp_I)+2 3677 ii=il_shape1( 1)-ji+13863 ii=il_shape1(jp_I)-ji+1 3678 3864 IF( dl_lon1(ii,1) < dl_lon0(id_imax0-1,id_jmin0) + dp_delta )THEN 3679 grid__get_fine_offset_cc( 1,2)=(id_rho(jp_I)+1)-ji3865 grid__get_fine_offset_cc(jp_I,2)=(id_rho(jp_I)+1)-ji 3680 3866 EXIT 3681 3867 ENDIF … … 3686 3872 ENDIF 3687 3873 3688 ELSE 3689 grid__get_fine_offset_cc(1,:)=((id_rho(jp_I)-1)/2)3690 ENDIF3691 3692 IF( il_shape1(2) > 1 )THEN3874 ELSEIF( il_shape1(jp_I) == 1 )THEN 3875 3876 grid__get_fine_offset_cc(jp_I,:)=((id_rho(jp_I)-1)/2) 3877 3878 ! work on j-direction 3693 3879 3694 3880 ! look for j-direction lower offset … … 3696 3882 DO jj=1,id_rho(jp_J)+2 3697 3883 IF( dd_lat1(1,jj) > dd_lat0(id_imin0,id_jmin0+1) - dp_delta )THEN 3698 grid__get_fine_offset_cc( 2,1)=(id_rho(jp_J)+1)-jj3884 grid__get_fine_offset_cc(jp_J,1)=(id_rho(jp_J)+1)-jj 3699 3885 EXIT 3700 3886 ENDIF … … 3706 3892 3707 3893 ! look for j-direction upper offset 3708 IF( dd_lat1(1,il_shape1( 2)) > dd_lat0(id_imin0,id_jmax0-1) )THEN3894 IF( dd_lat1(1,il_shape1(jp_J)) > dd_lat0(id_imin0,id_jmax0-1) )THEN 3709 3895 DO jj=1,id_rho(jp_J)+2 3710 ij=il_shape1( 2)-jj+13896 ij=il_shape1(jp_J)-jj+1 3711 3897 IF( dd_lat1(1,ij) < dd_lat0(id_imin0,id_jmax0-1) + dp_delta )THEN 3712 grid__get_fine_offset_cc( 2,2)=(id_rho(jp_J)+1)-jj3898 grid__get_fine_offset_cc(jp_J,2)=(id_rho(jp_J)+1)-jj 3713 3899 EXIT 3714 3900 ENDIF … … 3717 3903 CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//& 3718 3904 & " not match fine grid upper right corner.") 3719 ENDIF 3720 ELSE 3721 grid__get_fine_offset_cc(2,:)=((id_rho(jp_J)-1)/2) 3905 ENDIF 3906 3907 ELSE ! il_shape1(1) > 1 .AND. il_shape1(2) > 1 3908 3909 ! look for lower left offset 3910 IF( dl_lon1(1,1) < dl_lon0(id_imin0+1,id_jmin0+1) )THEN 3911 3912 ii=1 3913 ij=1 3914 DO ji=1,(id_rho(jp_I)+2)*(id_rho(jp_J)+2) 3915 3916 ll_ii=.FALSE. 3917 ll_ij=.FALSE. 3918 3919 IF( dl_lon1(ii,ij) >= dl_lon0(id_imin0+1,id_jmin0+1)-dp_delta .AND. & 3920 & dd_lat1(ii,ij) >= dd_lat0(id_imin0+1,id_jmin0+1)-dp_delta )THEN 3921 grid__get_fine_offset_cc(jp_I,1)=(id_rho(jp_I)+1)-ii 3922 grid__get_fine_offset_cc(jp_J,1)=(id_rho(jp_J)+1)-ij 3923 EXIT 3924 ENDIF 3925 3926 IF( dl_lon1(ii+1,ij) <= dl_lon0(id_imin0+1,id_jmin0+1)+dp_delta .AND. & 3927 & dd_lat1(ii+1,ij) <= dd_lat0(id_imin0+1,id_jmin0+1)+dp_delta )THEN 3928 ll_ii=.TRUE. 3929 ENDIF 3930 IF( dl_lon1(ii,ij+1) <= dl_lon0(id_imin0+1,id_jmin0+1)+dp_delta .AND. & 3931 & dd_lat1(ii,ij+1) <= dd_lat0(id_imin0+1,id_jmin0+1)+dp_delta )THEN 3932 ll_ij=.TRUE. 3933 ENDIF 3934 3935 IF( ll_ii ) ii=ii+1 3936 IF( ll_ij ) ij=ij+1 3937 3938 ENDDO 3939 3940 ELSE 3941 CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//& 3942 & " not match fine grid lower left corner.") 3943 ENDIF 3944 3945 ! look for upper right offset 3946 IF( dl_lon1(il_shape1(jp_I),il_shape1(jp_J)) > & 3947 & dl_lon0(id_imax0-1,id_jmax0-1) )THEN 3948 3949 ii=il_shape1(jp_I) 3950 ij=il_shape1(jp_J) 3951 DO ji=1,(id_rho(jp_I)+2)*(id_rho(jp_J)+2) 3952 3953 ll_ii=.FALSE. 3954 ll_ij=.FALSE. 3955 3956 IF( dl_lon1(ii,ij) <= dl_lon0(id_imax0-1,id_jmax0-1)+dp_delta .AND. & 3957 & dd_lat1(ii,ij) <= dd_lat0(id_imax0-1,id_jmax0-1)+dp_delta )THEN 3958 grid__get_fine_offset_cc(jp_I,2)=(id_rho(jp_I)+1)-(il_shape1(jp_I)+1-ii) 3959 grid__get_fine_offset_cc(jp_J,2)=(id_rho(jp_J)+1)-(il_shape1(jp_J)+1-ij) 3960 EXIT 3961 ENDIF 3962 3963 IF( dl_lon1(ii-1,ij) >= dl_lon0(id_imax0-1,id_jmax0-1)-dp_delta .AND. & 3964 & dd_lat1(ii-1,ij) >= dd_lat0(id_imax0-1,id_jmax0-1)-dp_delta )THEN 3965 ll_ii=.TRUE. 3966 ENDIF 3967 IF( dl_lon1(ii,ij-1) >= dl_lon0(id_imax0-1,id_jmax0-1)-dp_delta .AND. & 3968 & dd_lat1(ii,ij-1) >= dd_lat0(id_imax0-1,id_jmax0-1)-dp_delta )THEN 3969 ll_ij=.TRUE. 3970 ENDIF 3971 3972 IF( ll_ii ) ii=ii-1 3973 IF( ll_ij ) ij=ij-1 3974 3975 ENDDO 3976 3977 ELSE 3978 CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//& 3979 & " not match fine grid upper right corner.") 3980 ENDIF 3981 3722 3982 ENDIF 3723 3983 … … 3732 3992 ! 3733 3993 !> @author J.Paul 3734 !> -November, 2013- Initial Version3994 !> @date November, 2013- Initial Version 3735 3995 !> @date October, 2014 3736 3996 !> - work on mpp file structure instead of file structure … … 3742 4002 !> @param[in] id_jmin0 coarse grid lower left corner j-indice of fine grid domain 3743 4003 !> @param[in] id_jmax0 coarse grid upper right corner j-indice of fine grid domain 3744 !> @param[in] id_rho array of refinement factor (default 1)4004 !> @param[in] id_rho array of refinement factor 3745 4005 !------------------------------------------------------------------- 3746 4006 SUBROUTINE grid_check_coincidence( td_coord0, td_coord1, & … … 4042 4302 !> 4043 4303 !> @author J.Paul 4044 !> - November, 2013- Initial Version4304 !> @date November, 2013 - Initial Version 4045 4305 ! 4046 4306 !> @param[in] dd_lon0 array of coarse grid longitude … … 4103 4363 dl_lon1 = dd_lon1(il_imin1, il_jmin1) 4104 4364 dl_lat1 = dd_lat1(il_imin1, il_jmin1) 4105 4106 4365 4107 4366 IF( (ABS(dl_lon1-dl_lon0)>dp_delta) .AND. (dl_lon1 < dl_lon0 ) .OR. & … … 4202 4461 ! 4203 4462 !> @author J.Paul 4204 !> - November, 2013- Initial Version4463 !> @date November, 2013 - Initial Version 4205 4464 ! 4206 4465 !> @param[in] dd_lat0 array of coarse grid latitude … … 4272 4531 !> 4273 4532 !> @author J.Paul 4274 !> - November, 2013-Initial version4533 !> @date November, 2013 - Initial version 4275 4534 ! 4276 4535 !> @param[inout] td_var array of variable structure … … 4348 4607 !> 4349 4608 !> @author J.Paul 4350 !> - November, 2013-Initial version4609 !> @date November, 2013 - Initial version 4351 4610 ! 4352 4611 !> @param[inout] td_var array of variable structure … … 4374 4633 IF( ALL(td_var%t_dim(1:2)%l_use) )THEN 4375 4634 4376 CALL logger_warn( "GRID DEL GHOST: dimension change in variable "//& 4377 & TRIM(td_var%c_name) ) 4635 IF( ANY(id_ghost(:,:)/=0) )THEN 4636 CALL logger_warn( "GRID DEL GHOST: dimension change in variable "//& 4637 & TRIM(td_var%c_name) ) 4638 ENDIF 4378 4639 4379 4640 ! copy variable … … 4425 4686 !> 4426 4687 !> @author J.Paul 4427 !> - September, 2014- Initial Version4688 !> @date September, 2014 - Initial Version 4428 4689 ! 4429 4690 !> @param[in] td_var variable sturcture … … 4555 4816 !> 4556 4817 !> @author J.Paul 4557 !> -September, 2014 - Initial Version4818 !> @date September, 2014 - Initial Version 4558 4819 !> @date October, 2014 4559 4820 !> - work on mpp file structure instead of file structure … … 4592 4853 tl_mpp=mpp_copy(td_mpp) 4593 4854 4855 CALL logger_info("GRID GET FINE GHOST perio"//TRIM(fct_str(tl_mpp%i_perio))) 4594 4856 IF( tl_mpp%i_perio < 0 )THEN 4595 4857 ! compute NEMO periodicity index … … 4627 4889 !> 4628 4890 !> @author J.Paul 4629 !> - November, 2013- Initial Version4891 !> @date November, 2013 - Initial Version 4630 4892 ! 4631 4893 !> @param[in] td_var variable strucutre … … 4694 4956 il_tmp(jim:jip,jjm:jjp)=1 4695 4957 END WHERE 4958 4696 4959 ENDIF 4697 4960 ENDDO … … 4720 4983 !> 4721 4984 !> @details 4722 !> the minimum size (n bumber of point) of closed sea to be kept could be4985 !> the minimum size (number of point) of closed sea to be kept could be 4723 4986 !> sepcify with id_minsize. 4724 4987 !> By default only the biggest sea is preserve. 4725 4988 !> 4726 4989 !> @author J.Paul 4727 !> - November, 2013- Initial Version4990 !> @date November, 2013 - Initial Version 4728 4991 !> 4729 4992 !> @param[inout] td_var variable structure … … 4782 5045 4783 5046 END SUBROUTINE grid_fill_small_dom 5047 !------------------------------------------------------------------- 5048 !> @brief This subroutine fill small domain inside bigger one. 5049 !> 5050 !> @details 5051 !> the minimum size (number of point) of domain sea to be kept could be 5052 !> is sepcified with id_minsize. 5053 !> smaller domain are included in the one they are embedded. 5054 !> 5055 !> @author J.Paul 5056 !> @date Ferbruay, 2015 - Initial Version 5057 !> 5058 !> @param[inout] id_mask domain mask (from grid_split_domain) 5059 !> @param[in] id_minsize minimum size of sea to be kept 5060 !------------------------------------------------------------------- 5061 SUBROUTINE grid_fill_small_msk(id_mask, id_minsize) 5062 IMPLICIT NONE 5063 ! Argument 5064 INTEGER(i4), DIMENSION(:,:), INTENT(INOUT) :: id_mask 5065 INTEGER(i4), INTENT(IN ) :: id_minsize 5066 5067 ! local variable 5068 INTEGER(i4) :: il_ndom 5069 INTEGER(i4) :: il_minsize 5070 INTEGER(i4) :: il_msk 5071 5072 INTEGER(i4) :: jim 5073 INTEGER(i4) :: jjm 5074 INTEGER(i4) :: jip 5075 INTEGER(i4) :: jjp 5076 5077 INTEGER(i4), DIMENSION(2) :: il_shape 5078 INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_tmp 5079 5080 ! loop indices 5081 INTEGER(i4) :: ii 5082 INTEGER(i4) :: ij 5083 5084 INTEGER(i4) :: ji 5085 INTEGER(i4) :: jj 5086 !---------------------------------------------------------------- 5087 5088 il_shape(:)=SHAPE(id_mask(:,:)) 5089 il_ndom=MINVAL(id_mask(:,:)) 5090 5091 ALLOCATE( il_tmp(il_shape(1),il_shape(2)) ) 5092 il_tmp(:,:)=0 5093 DO ji=-1,il_ndom,-1 5094 WHERE( id_mask(:,:)==ji ) 5095 il_tmp(:,:)=SUM(id_mask(:,:),id_mask(:,:)==ji)/ji 5096 END WHERE 5097 ENDDO 5098 5099 DO WHILE( id_minsize > MINVAL(il_tmp(:,:)) ) 5100 5101 DO jj=1,il_shape(2) 5102 DO ji=1,il_shape(1) 5103 5104 IF( il_tmp(ji,jj) < il_minsize )THEN 5105 jim=MAX(1,ji-1) ; jip=MIN(il_shape(1),ji+1) 5106 jjm=MAX(1,jj-1) ; jjp=MIN(il_shape(2),jj+1) 5107 5108 il_msk=0 5109 DO ij=jjm,jjp 5110 DO ii=jim,jip 5111 IF( id_mask(ii,ij) /= id_mask(ji,jj) )THEN 5112 IF( il_msk == 0 )THEN 5113 il_msk=id_mask(ii,ij) 5114 ELSEIF( il_msk /= id_mask(ii,ij) )THEN 5115 CALL logger_error("GRID FILL SMALL MSK: "//& 5116 & "small domain not embedded in bigger one"//& 5117 & ". point should be between two different"//& 5118 & " domain.") 5119 ENDIF 5120 ENDIF 5121 ENDDO 5122 ENDDO 5123 IF( il_msk /= 0 ) id_mask(ji,jj)=il_msk 5124 5125 ENDIF 5126 5127 ENDDO 5128 ENDDO 5129 5130 5131 il_tmp(:,:)=0 5132 DO ji=-1,il_ndom,-1 5133 WHERE( id_mask(:,:)==ji ) 5134 il_tmp(:,:)=SUM(id_mask(:,:),id_mask(:,:)==ji)/ji 5135 END WHERE 5136 ENDDO 5137 5138 ENDDO 5139 5140 DEALLOCATE( il_tmp ) 5141 5142 5143 END SUBROUTINE grid_fill_small_msk 4784 5144 END MODULE grid 4785 5145 -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/interp.f90
r5037 r6487 27 27 !> defining string character _cn\_varinfo_.<br/> 28 28 !> Example: 29 !> - cn_varinfo='varname1: cubic/rhoi', 'varname2:linear'29 !> - cn_varinfo='varname1:int=cubic/rhoi', 'varname2:int=linear' 30 30 !> 31 31 !> to create mixed grid (with coarse grid point needed to compute … … 137 137 !> 138 138 !> @author J.Paul 139 !> - November, 2013- Initial Version139 !> @date November, 2013 - Initial Version 140 140 ! 141 141 !> @param[in] cd_method interpolation method … … 179 179 !> 180 180 !> @author J.Paul 181 !> - November, 2013- Initial Version181 !> @date November, 2013 - Initial Version 182 182 !> 183 183 !> @param[in] td_mix mixed grid variable (to interpolate) … … 244 244 !> 245 245 !> @author J.Paul 246 !> - November, 2013- Initial Version246 !> @date November, 2013 - Initial Version 247 247 ! 248 248 !> @param[in] td_mix mixed grid variable (to interpolate) … … 363 363 !> 364 364 !> @author J.Paul 365 !> - November, 2013- Initial Version365 !> @date November, 2013 - Initial Version 366 366 !> 367 367 !> @param[in] td_var coarse grid variable (should be extrapolated) … … 449 449 !> 450 450 !> @author J.Paul 451 !> - November, 2013- Initial Version451 !> @date November, 2013 - Initial Version 452 452 !> 453 453 !> @param[inout] td_mix mixed grid variable … … 610 610 !> 611 611 !> @author J.Paul 612 !> - November, 2013- Initial Version612 !> @date November, 2013 - Initial Version 613 613 !> @date September, 2014 614 614 !> - use offset to save useful domain … … 716 716 !> 717 717 !> @author J.Paul 718 !> - November, 2013- Initial Version718 !> @date November, 2013 - Initial Version 719 719 !> 720 720 !> @param[inout] td_var variable structure … … 828 828 !> 829 829 !> @author J.Paul 830 !> - November, 2013- Initial Version830 !> @date November, 2013 - Initial Version 831 831 !> @date September, 2014 832 832 !> - use interpolation method modules … … 947 947 948 948 DEALLOCATE(il_detect) 949 949 950 !4- save useful domain (remove offset) 950 951 CALL interp_clean_mixed_grid( tl_mix, td_var, & -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/interp_cubic.f90
r5037 r6487 26 26 ! REVISION HISTORY: 27 27 !> @date September, 2014 -Initial version 28 !> @date June, 2015 29 !> - use math module 28 30 !> 29 31 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 36 38 USE logger ! log file manager 37 39 USE fct ! basic useful function 38 USE extrap ! extrapolation manager40 USE math ! mathematical function 39 41 40 42 IMPLICIT NONE … … 61 63 !> 62 64 !> @author J.Paul 63 !> - September, 2014- Initial Version 65 !> @date September, 2014 - Initial Version 66 !> @date July, 2015 67 !> - reinitialise detect array for each level 64 68 !> 65 69 !> @param[inout] dd_value 2D array of variable value … … 82 86 83 87 ! local variable 84 INTEGER(i4), DIMENSION(4) :: il_shape 85 86 LOGICAL :: ll_discont 87 88 REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_weight_IJ 89 REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_weight_I 90 REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_weight_J 88 INTEGER(i4), DIMENSION(4) :: il_shape 89 90 INTEGER(I4), DIMENSION(:,:,:), ALLOCATABLE :: il_detect 91 92 LOGICAL :: ll_discont 93 94 REAL(dp) , DIMENSION(:,:) , ALLOCATABLE :: dl_weight_IJ 95 REAL(dp) , DIMENSION(:,:) , ALLOCATABLE :: dl_weight_I 96 REAL(dp) , DIMENSION(:,:) , ALLOCATABLE :: dl_weight_J 91 97 92 98 ! loop indices … … 113 119 & id_rho(jp_J), ld_even(jp_J)) 114 120 121 ALLOCATE(il_detect(il_shape(1),il_shape(2),il_shape(3))) 122 115 123 DO jl=1,il_shape(4) 124 il_detect(:,:,:)=id_detect(:,:,:) 116 125 ! loop on vertical level 117 126 DO jk=1,il_shape(3) … … 119 128 ! I-J plan 120 129 CALL interp_cubic__2D(dd_value(:,:,jk,jl), dd_fill, & 121 & i d_detect(:,:,jk), &130 & il_detect(:,:,jk), & 122 131 & dl_weight_IJ(:,:), & 123 132 & id_rho(jp_I), id_rho(jp_J), & 124 133 & ll_discont) 125 IF( ANY(i d_detect(:,:,jk)==1) )THEN134 IF( ANY(il_detect(:,:,jk)==1) )THEN 126 135 ! I direction 127 136 DO jj=1,il_shape(2) 128 137 CALL interp_cubic__1D( dd_value(:,jj,jk,jl), dd_fill, & 129 & i d_detect(:,jj,jk), &138 & il_detect(:,jj,jk), & 130 139 & dl_weight_I(:,:), & 131 140 & id_rho(jp_I), ll_discont ) 132 141 ENDDO 133 IF( ALL(i d_detect(:,:,jk)==0) )THEN142 IF( ALL(il_detect(:,:,jk)==0) )THEN 134 143 CYCLE 135 144 ELSE … … 137 146 DO ji=1,il_shape(1) 138 147 CALL interp_cubic__1D( dd_value(ji,:,jk,jl), dd_fill, & 139 & i d_detect(ji,:,jk), &148 & il_detect(ji,:,jk), & 140 149 & dl_weight_J(:,:), & 141 150 & id_rho(jp_J), ll_discont ) … … 147 156 ENDDO 148 157 158 id_detect(:,:,:)=il_detect(:,:,:) 159 DEALLOCATE(il_detect) 160 149 161 DEALLOCATE(dl_weight_IJ) 150 162 DEALLOCATE(dl_weight_I) … … 159 171 !> 160 172 !> @author J.Paul 161 !> - September, 2014- Initial Version173 !> @date September, 2014 - Initial Version 162 174 !> 163 175 !> @param[inout] dd_value 2D array of variable value … … 181 193 REAL(dp) , INTENT(IN ) :: dd_fill 182 194 INTEGER(I4) , DIMENSION(:,:), INTENT(INOUT) :: id_detect 183 REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_weight 195 REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_weight 184 196 INTEGER(I4) , INTENT(IN ) :: id_rhoi 185 197 INTEGER(I4) , INTENT(IN ) :: id_rhoj … … 230 242 231 243 ! compute derivative on coarse grid 232 dl_dfdx(:,:)= extrap_deriv_2D(dl_coarse(:,:), dd_fill, 'I', ld_discont)233 dl_dfdy(:,:)= extrap_deriv_2D(dl_coarse(:,:), dd_fill, 'J', ld_discont)244 dl_dfdx(:,:)=math_deriv_2D(dl_coarse(:,:), dd_fill, 'I', ld_discont) 245 dl_dfdy(:,:)=math_deriv_2D(dl_coarse(:,:), dd_fill, 'J', ld_discont) 234 246 235 247 ! compute cross derivative on coarse grid 236 dl_d2fdxy(:,:)= extrap_deriv_2D(dl_dfdx(:,:), dd_fill, 'J', ld_discont)248 dl_d2fdxy(:,:)=math_deriv_2D(dl_dfdx(:,:), dd_fill, 'J', ld_discont) 237 249 238 250 ALLOCATE( dl_tmp(2,2) ) … … 319 331 !> 320 332 !> @author J.Paul 321 !> - September, 2014- Initial Version333 !> @date September, 2014 - Initial Version 322 334 !> 323 335 !> @param[inout] dd_value 1D array of variable value … … 339 351 REAL(dp) , INTENT(IN ) :: dd_fill 340 352 INTEGER(I4) , DIMENSION(:) , INTENT(INOUT) :: id_detect 341 REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_weight 353 REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_weight 342 354 INTEGER(I4) , INTENT(IN ) :: id_rhoi 343 355 LOGICAL , INTENT(IN ) :: ld_discont … … 376 388 377 389 ! compute derivative on coarse grid 378 dl_dfdx(:)= extrap_deriv_1D(dl_coarse(:), dd_fill, ld_discont)390 dl_dfdx(:)=math_deriv_1D(dl_coarse(:), dd_fill, ld_discont) 379 391 380 392 ALLOCATE( dl_tmp(2) ) … … 440 452 !> 441 453 !> @author J.Paul 442 !> - September, 2014- Initial Version454 !> @date September, 2014 - Initial Version 443 455 !> 444 456 !> @param[in] dd_value 2D array of value … … 503 515 !> 504 516 !> @author J.Paul 505 !> - September, 2014- Initial Version517 !> @date September, 2014 - Initial Version 506 518 !> 507 519 !> @param[inout] dd_value 2D array of mixed grid value … … 565 577 !> 566 578 !> @author J.Paul 567 !> - September, 2014- Initial Version579 !> @date September, 2014 - Initial Version 568 580 !> 569 581 !> @param[in] dd_value 1D array of value … … 608 620 !> 609 621 !> @author J.Paul 610 !> - September, 2014- Initial Version622 !> @date September, 2014 - Initial Version 611 623 !> 612 624 !> @param[inout] dd_value 1D array of mixed grid value … … 659 671 !> 660 672 !> @author J.Paul 661 !> - September, 2014- Initial Version673 !> @date September, 2014 - Initial Version 662 674 !> 663 675 !> @param[in] dd_weight interpolation weight of 2D array … … 740 752 !> 741 753 !> @author J.Paul 742 !> - September, 2014- Initial Version754 !> @date September, 2014 - Initial Version 743 755 !> 744 756 !> @param[in] dd_weight interpolation weight of 1D array -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/interp_linear.f90
r5037 r6487 24 24 !> J.Paul 25 25 ! REVISION HISTORY: 26 !> @date September, 2014 - Initial version26 !> @date September, 2014 - Initial version 27 27 !> 28 28 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 63 63 !> 64 64 !> @author J.Paul 65 !> - September, 2014- Initial Version 65 !> @date September, 2014 - Initial Version 66 !> @date July, 2015 - reinitialise detect array for each level 66 67 !> 67 68 !> @param[inout] dd_value 2D array of variable value … … 84 85 85 86 ! local variable 86 INTEGER(i4), DIMENSION(4) :: il_shape 87 88 LOGICAL :: ll_discont 89 90 REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_weight_IJ 91 REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_weight_I 92 REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_weight_J 87 INTEGER(i4), DIMENSION(4) :: il_shape 88 89 INTEGER(I4), DIMENSION(:,:,:), ALLOCATABLE :: il_detect 90 91 LOGICAL :: ll_discont 92 93 REAL(dp) , DIMENSION(:,:) , ALLOCATABLE :: dl_weight_IJ 94 REAL(dp) , DIMENSION(:,:) , ALLOCATABLE :: dl_weight_I 95 REAL(dp) , DIMENSION(:,:) , ALLOCATABLE :: dl_weight_J 93 96 94 97 ! loop indices … … 104 107 105 108 ! compute vect2D 106 ALLOCATE(dl_weight_IJ( 16,((id_rho(jp_I)+1)*(id_rho(jp_J)+1))) )109 ALLOCATE(dl_weight_IJ(4,((id_rho(jp_I)+1)*(id_rho(jp_J)+1))) ) 107 110 CALL interp_linear__get_weight2D(dl_weight_IJ(:,:), & 108 111 & id_rho(:), ld_even(:)) 109 112 110 ALLOCATE( dl_weight_I( 4,((id_rho(jp_I)+1) )) )111 ALLOCATE( dl_weight_J( 4,( (id_rho(jp_J)+1))) )113 ALLOCATE( dl_weight_I( 2,((id_rho(jp_I)+1) )) ) 114 ALLOCATE( dl_weight_J( 2,( (id_rho(jp_J)+1))) ) 112 115 CALL interp_linear__get_weight1D(dl_weight_I(:,:), & 113 116 & id_rho(jp_I), ld_even(jp_I)) … … 115 118 & id_rho(jp_J), ld_even(jp_J)) 116 119 120 ALLOCATE(il_detect(il_shape(1),il_shape(2),il_shape(3))) 121 117 122 DO jl=1,il_shape(4) 123 il_detect(:,:,:)=id_detect(:,:,:) 118 124 ! loop on vertical level 119 125 DO jk=1,il_shape(3) … … 121 127 ! I-J plan 122 128 CALL interp_linear__2D(dd_value(:,:,jk,jl), dd_fill,& 123 & i d_detect(:,:,jk), &129 & il_detect(:,:,jk), & 124 130 & dl_weight_IJ(:,:), & 125 131 & id_rho(jp_I), id_rho(jp_J), & 126 132 & ll_discont) 127 IF( ANY(i d_detect(:,:,jk)==1) )THEN133 IF( ANY(il_detect(:,:,jk)==1) )THEN 128 134 ! I direction 129 135 DO jj=1,il_shape(2) 130 136 CALL interp_linear__1D( dd_value(:,jj,jk,jl), dd_fill,& 131 & i d_detect(:,jj,jk), &137 & il_detect(:,jj,jk), & 132 138 & dl_weight_I(:,:), & 133 139 & id_rho(jp_I), ll_discont ) 134 140 ENDDO 135 IF( ALL(i d_detect(:,:,jk)==0) )THEN141 IF( ALL(il_detect(:,:,jk)==0) )THEN 136 142 CYCLE 137 143 ELSE … … 139 145 DO ji=1,il_shape(1) 140 146 CALL interp_linear__1D( dd_value(ji,:,jk,jl), dd_fill,& 141 & i d_detect(ji,:,jk), &147 & il_detect(ji,:,jk), & 142 148 & dl_weight_J(:,:), & 143 149 & id_rho(jp_J), ll_discont ) … … 149 155 ENDDO 150 156 157 id_detect(:,:,:)=il_detect(:,:,:) 158 DEALLOCATE(il_detect) 159 151 160 DEALLOCATE(dl_weight_IJ) 152 161 DEALLOCATE(dl_weight_I) 153 162 DEALLOCATE(dl_weight_J) 154 163 155 164 END SUBROUTINE interp_linear_fill 156 165 !------------------------------------------------------------------- … … 161 170 !> 162 171 !> @author J.Paul 163 !> - September, 2014- Initial Version172 !> @date September, 2014 - Initial Version 164 173 !> 165 174 !> @param[inout] dd_value 2D array of variable value … … 235 244 IF( ALL(id_detect(ji:ji+id_rhoi, & 236 245 & jj:jj+id_rhoj)==0) ) CYCLE 237 ! check data toneeded to interpolate246 ! check data needed to interpolate 238 247 IF( ANY(dl_coarse(ii:ii+1,ij:ij+1)==dd_fill) ) CYCLE 239 248 ! check longitude discontinuity … … 296 305 !> 297 306 !> @author J.Paul 298 !> - September, 2014- Initial Version307 !> @date September, 2014 - Initial Version 299 308 !> 300 309 !> @param[inout] dd_value 1D array of variable value … … 408 417 !> 409 418 !> @author J.Paul 410 !> - September, 2014- Initial Version419 !> @date September, 2014 - Initial Version 411 420 !> 412 421 !> @param[in] dd_value 2D array of value … … 445 454 !> 446 455 !> @author J.Paul 447 !> - September, 2014- Initial Version448 !> 456 !> @date September, 2014 - Initial Version 457 !> 449 458 !> @param[inout] dd_value 2D array of mixed grid value 450 459 !> @param[inout] id_detect 2D array of point to be interpolated … … 477 486 !---------------------------------------------------------------- 478 487 479 IF( ANY( dd_coef(:)==dd_fill ) )THEN 480 CALL logger_error("INTERP LINEAR FILL: fill value detected in coef. "//& 481 & "can not compute interpolation.") 482 ELSE 483 484 ii=0 485 DO jj=1,id_rhoj+1 486 DO ji=1,id_rhoi+1 487 488 ii=ii+1 489 IF(id_detect(ji,jj)==1)THEN 490 491 dd_value(ji,jj)=DOT_PRODUCT(dd_coef(:),dd_weight(:,ii)) 492 id_detect(ji,jj)=0 493 494 ENDIF 495 496 ENDDO 488 IF( ANY( dd_coef(:)==dd_fill ) )THEN 489 CALL logger_error("INTERP LINEAR FILL: fill value detected in coef. "//& 490 & "can not compute interpolation.") 491 ELSE 492 493 ii=0 494 DO jj=1,id_rhoj+1 495 DO ji=1,id_rhoi+1 496 497 ii=ii+1 498 IF(id_detect(ji,jj)==1)THEN 499 500 dd_value(ji,jj)=DOT_PRODUCT(dd_coef(:),dd_weight(:,ii)) 501 id_detect(ji,jj)=0 502 503 ENDIF 504 497 505 ENDDO 498 499 ENDIF 506 ENDDO 507 508 ENDIF 500 509 501 510 END SUBROUTINE interp_linear__2D_fill … … 505 514 !> 506 515 !> @author J.Paul 507 !> - September, 2014- Initial Version516 !> @date September, 2014 - Initial Version 508 517 !> 509 518 !> @param[in] dd_value 1D array of value … … 540 549 !> 541 550 !> @author J.Paul 542 !> - September, 2014- Initial Version551 !> @date September, 2014 - Initial Version 543 552 !> 544 553 !> @param[inout] dd_value 1D array of mixed grid value … … 591 600 !> 592 601 !> @author J.Paul 593 !> - September, 2014- Initial Version602 !> @date September, 2014 - Initial Version 594 603 !> 595 604 !> @param[in] dd_weight interpolation weight of 2D array … … 660 669 !> 661 670 !> @author J.Paul 662 !> - September, 2014- Initial Version671 !> @date September, 2014 - Initial Version 663 672 !> 664 673 !> @param[in] dd_weight interpolation weight of 1D array -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/interp_nearest.f90
r5037 r6487 24 24 !> J.Paul 25 25 ! REVISION HISTORY: 26 !> @date September, 2014 - Initial version26 !> @date September, 2014 - Initial version 27 27 !> 28 28 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 55 55 !> 56 56 !> @author J.Paul 57 !> - September, 2014- Initial Version57 !> @date September, 2014 - Initial Version 58 58 !> 59 59 !> @param[inout] dd_value 2D array of variable value … … 69 69 70 70 ! local variable 71 INTEGER(i4), DIMENSION(4) :: il_shape 71 INTEGER(i4), DIMENSION(4) :: il_shape 72 73 INTEGER(I4), DIMENSION(:,:,:), ALLOCATABLE :: il_detect 72 74 73 75 ! loop indices … … 80 82 il_shape(:)=SHAPE(dd_value) 81 83 84 ALLOCATE(il_detect(il_shape(1),il_shape(2),il_shape(3))) 82 85 DO jl=1,il_shape(4) 86 il_detect(:,:,:)=id_detect(:,:,:) 83 87 ! loop on vertical level 84 88 DO jk=1,il_shape(3) … … 86 90 ! I-J plan 87 91 CALL interp_nearest__2D(dd_value(:,:,jk,jl),& 88 & i d_detect(:,:,jk), &92 & il_detect(:,:,jk), & 89 93 & id_rho(jp_I), id_rho(jp_J) ) 90 IF( ANY(i d_detect(:,:,jk)==1) )THEN94 IF( ANY(il_detect(:,:,jk)==1) )THEN 91 95 ! I direction 92 96 DO jj=1,il_shape(2) 93 97 CALL interp_nearest__1D( dd_value(:,jj,jk,jl),& 94 & i d_detect(:,jj,jk), &98 & il_detect(:,jj,jk), & 95 99 & id_rho(jp_I) ) 96 100 ENDDO 97 IF( ALL(i d_detect(:,:,jk)==0) )THEN101 IF( ALL(il_detect(:,:,jk)==0) )THEN 98 102 CYCLE 99 103 ELSE … … 101 105 DO ji=1,il_shape(1) 102 106 CALL interp_nearest__1D( dd_value(ji,:,jk,jl),& 103 & i d_detect(ji,:,jk), &107 & il_detect(ji,:,jk), & 104 108 & id_rho(jp_J) ) 105 109 ENDDO … … 110 114 ENDDO 111 115 116 id_detect(:,:,:)=il_detect(:,:,:) 117 DEALLOCATE(il_detect) 118 112 119 END SUBROUTINE interp_nearest_fill 113 120 !------------------------------------------------------------------- … … 116 123 !> 117 124 !> @author J.Paul 118 !> - September, 2014- Initial Version125 !> @date September, 2014 - Initial Version 119 126 !> 120 127 !> @param[inout] dd_value 2D array of variable value … … 171 178 !> 172 179 !> @author J.Paul 173 !> - September, 2014- Initial Version180 !> @date September, 2014 - Initial Version 174 181 !> 175 182 !> @param[inout] dd_value 1D array of variable value … … 216 223 !> 217 224 !> @author J.Paul 218 !> - September, 2014- Initial Version225 !> @date September, 2014 - Initial Version 219 226 !> 220 227 !> @param[inout] dd_value 2D array of mixed grid value … … 300 307 !> 301 308 !> @author J.Paul 302 !> - September, 2014- Initial Version309 !> @date September, 2014 - Initial Version 303 310 !> 304 311 !> @param[inout] dd_value 1D array of mixed grid value -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/iom.f90
r5037 r6487 156 156 !> 157 157 !> @author J.Paul 158 !> - November, 2013- Initial Version158 !> @date November, 2013 - Initial Version 159 159 ! 160 160 !> @param[inout] td_file file structure … … 186 186 !> 187 187 !> @author J.Paul 188 !> - November, 2013- Initial Version188 !> @date November, 2013 - Initial Version 189 189 ! 190 190 !> @param[inout] td_file file structure … … 223 223 !> 224 224 !> @author J.Paul 225 !> - November, 2013- Initial Version225 !> @date November, 2013 - Initial Version 226 226 ! 227 227 !> @param[inout] td_file file structure … … 252 252 ! 253 253 !> @author J.Paul 254 !> - November, 2013- Initial Version254 !> @date November, 2013 - Initial Version 255 255 ! 256 256 !> @param[in] td_file file structure … … 300 300 !> 301 301 !> @author J.Paul 302 !> - November, 2013- Initial Version302 !> @date November, 2013 - Initial Version 303 303 ! 304 304 !> @param[in] td_file file structure … … 338 338 ! 339 339 !> @author J.Paul 340 !> - November, 2013- Initial Version340 !> @date November, 2013 - Initial Version 341 341 ! 342 342 !> @param[in] td_file file structure … … 386 386 ! 387 387 !> @author J.Paul 388 !> - November, 2013- Initial Version388 !> @date November, 2013 - Initial Version 389 389 ! 390 390 !> @param[in] td_file file structure … … 422 422 ! 423 423 !> @author J.Paul 424 !> - November, 2013- Initial Version424 !> @date November, 2013 - Initial Version 425 425 ! 426 426 !> @param[in] td_file file structure … … 452 452 ! 453 453 !> @author J.Paul 454 !> - November, 2013- Initial Version454 !> @date November, 2013 - Initial Version 455 455 ! 456 456 !> @param[in] td_file file structure … … 485 485 ! 486 486 !> @author J.Paul 487 !> - November, 2013- Initial Version487 !> @date November, 2013 - Initial Version 488 488 ! 489 489 !> @param[in] td_file file structure … … 529 529 ! 530 530 !> @author J.Paul 531 !> - November, 2013- Initial Version531 !> @date November, 2013 - Initial Version 532 532 ! 533 533 !> @param[in] td_file file structure … … 564 564 !------------------------------------------------------------------- 565 565 !> @brief This subroutine write file structure in an opened file. 566 ! 567 !> @author J.Paul 568 !> - November, 2013- Initial Version 566 !> 567 !> @details 568 !> optionally, you could specify dimension order (default 'xyzt') 569 !> 570 !> @author J.Paul 571 !> @date November, 2013 - Initial Version 572 !> @date July, 2015 - add dimension order option 569 573 ! 570 574 !> @param[in] td_file file structure 571 575 !------------------------------------------------------------------- 572 SUBROUTINE iom_write_file(td_file) 573 IMPLICIT NONE 574 ! Argument 575 TYPE(TFILE), INTENT(INOUT) :: td_file 576 !---------------------------------------------------------------- 577 578 ! open file 579 SELECT CASE(TRIM(td_file%c_type)) 580 CASE('cdf') 581 CALL iom_cdf_write_file(td_file) 582 CASE('dimg') 576 SUBROUTINE iom_write_file(td_file, cd_dimorder) 577 IMPLICIT NONE 578 ! Argument 579 TYPE(TFILE) , INTENT(INOUT) :: td_file 580 CHARACTER(LEN=*), INTENT(IN ), OPTIONAL :: cd_dimorder 581 !---------------------------------------------------------------- 582 583 ! open file 584 SELECT CASE(TRIM(td_file%c_type)) 585 CASE('cdf') 586 CALL iom_cdf_write_file(td_file, cd_dimorder) 587 CASE('dimg') 588 ! note: can not change dimension order in restart dimg file 583 589 CALL iom_rstdimg_write_file(td_file) 584 590 CASE DEFAULT -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/iom_cdf.f90
r5037 r6487 144 144 !> 145 145 !> @author J.Paul 146 !> - November, 2013- Initial Version 147 ! 146 !> @date November, 2013 - Initial Version 147 !> @date May, 2015 - add optional message to netcdf error message 148 !> 148 149 !> @param[in] id_status error status 149 !------------------------------------------------------------------- 150 SUBROUTINE iom_cdf__check(id_status) 151 IMPLICIT NONE 152 ! Argument 153 INTEGER(i4), INTENT(IN) :: id_status 154 !---------------------------------------------------------------- 150 !> @param[in] cd_msg message 151 !------------------------------------------------------------------- 152 SUBROUTINE iom_cdf__check(id_status, cd_msg) 153 IMPLICIT NONE 154 ! Argument 155 INTEGER(i4) , INTENT(IN) :: id_status 156 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_msg 157 ! local variable 158 CHARACTER(LEN=lc) :: cl_msg 159 !---------------------------------------------------------------- 160 161 cl_msg="" 162 IF( PRESENT(cd_msg) ) cl_msg=cd_msg 155 163 156 164 IF( id_status /= NF90_NOERR )THEN 157 CALL logger_error(TRIM( NF90_STRERROR(id_status)))165 CALL logger_error(TRIM(cl_msg)//TRIM(NF90_STRERROR(id_status))) 158 166 ENDIF 159 167 … … 173 181 !> 174 182 !> @author J.Paul 175 !> - November, 2013- Initial Version183 !> @date November, 2013 - Initial Version 176 184 ! 177 185 !> @param[inout] td_file file structure … … 203 211 CALL logger_info( " IOM CDF CREATE: file "//TRIM(td_file%c_name) ) 204 212 205 il_status = NF90_CREATE( TRIM(td_file%c_name),& 206 & NF90_WRITE, & 207 & td_file%i_id) 208 CALL iom_cdf__check(il_status) 213 il_status = NF90_CREATE(TRIM(td_file%c_name),& 214 & cmode=NF90_64BIT_OFFSET,& 215 & ncid=td_file%i_id) 216 !NF90_WRITE, & 217 CALL iom_cdf__check(il_status," IOM CDF CREATE: ") 209 218 210 219 td_file%l_def=.TRUE. … … 228 237 & NF90_NOWRITE, & 229 238 & td_file%i_id) 230 CALL iom_cdf__check(il_status) 231 232 CALL logger_trace("IOM CDF OPEN "//TRIM(td_file%c_name)//" "//TRIM(fct_str(td_file%i_id))) 239 CALL iom_cdf__check(il_status," IOM CDF OPEN: ") 240 241 CALL logger_trace("IOM CDF OPEN "//TRIM(td_file%c_name)//" "//& 242 & TRIM(fct_str(td_file%i_id))) 233 243 ELSE 234 244 … … 239 249 & NF90_WRITE, & 240 250 & td_file%i_id) 241 CALL iom_cdf__check(il_status )251 CALL iom_cdf__check(il_status,"IOM CDF OPEN: ") 242 252 243 253 ENDIF … … 267 277 !> 268 278 !> @author J.Paul 269 !> - November, 2013- Initial Version279 !> @date November, 2013 - Initial Version 270 280 ! 271 281 !> @param[inout] td_file file structure … … 291 301 292 302 il_status = NF90_CLOSE(td_file%i_id) 293 CALL iom_cdf__check(il_status )303 CALL iom_cdf__check(il_status,"IOM CDF CLOSE: ") 294 304 295 305 td_file%i_id = 0 … … 307 317 !> 308 318 !> @author J.Paul 309 !> - November, 2013- Initial Version319 !> @date November, 2013 - Initial Version 310 320 ! 311 321 !> @param[inout] td_file file structure … … 326 336 il_status=NF90_INQUIRE(td_file%i_id, td_file%i_ndim, & 327 337 & td_file%i_nvar, td_file%i_natt, td_file%i_uldid, il_fmt) 328 CALL iom_cdf__check(il_status )338 CALL iom_cdf__check(il_status,"IOM CDF GET INFO: ") 329 339 330 340 SELECT CASE(il_fmt) … … 345 355 ! 346 356 !> @author J.Paul 347 !> - November, 2013- Initial Version357 !> @date November, 2013 - Initial Version 348 358 ! 349 359 !> @param[inout] td_file file structure … … 396 406 ! 397 407 !> @author J.Paul 398 !> - November, 2013- Initial Version408 !> @date November, 2013 - Initial Version 399 409 !> @date September, 2014 400 410 !> - use attribute periodicity read from the file if present. … … 439 449 ! 440 450 !> @author J.Paul 441 !> - November, 2013- Initial Version451 !> @date November, 2013 - Initial Version 442 452 ! 443 453 !> @param[inout] td_file file structure … … 480 490 481 491 ! look for depth id 482 IF( INDEX(TRIM( td_file%t_var(ji)%c_name),'depth') /=0 )THEN492 IF( INDEX(TRIM(fct_lower(td_file%t_var(ji)%c_name)),'depth')/=0 )THEN 483 493 IF( td_file%i_depthid == 0 )THEN 484 494 td_file%i_depthid=ji 485 495 ELSE 486 496 IF( td_file%i_depthid /= ji )THEN 487 CALL logger_error("IOM CDF GET FILE VAR: find more than one"//&488 & "depth variable in file "//&489 &TRIM(td_file%c_name) )497 CALL logger_error("IOM CDF GET FILE VAR: find more"//& 498 & " than one depth variable in file "//& 499 & TRIM(td_file%c_name) ) 490 500 ENDIF 491 501 ENDIF … … 493 503 494 504 ! look for time id 495 IF( INDEX(TRIM( td_file%t_var(ji)%c_name),'time') /=0 )THEN505 IF( INDEX(TRIM(fct_lower(td_file%t_var(ji)%c_name)),'time')/=0 )THEN 496 506 IF( td_file%i_timeid == 0 )THEN 497 507 td_file%i_timeid=ji … … 504 514 td_file%i_timeid=ji 505 515 !ELSE 506 ! print *,'error' 507 ! CALL logger_error("IOM OPEN: find more than one "//& 508 ! & "time variable in file "//& 516 ! CALL logger_error("IOM CDF GET FILE VAR: find more "//& 517 ! & "than one time variable in file "//& 509 518 ! & TRIM(td_file%c_name) ) 510 519 ENDIF … … 526 535 ! 527 536 !> @author J.Paul 528 !> - November, 2013- Initial Version537 !> @date November, 2013 - Initial Version 529 538 ! 530 539 !> @param[inout] td_file file structure … … 567 576 ! 568 577 !> @author J.Paul 569 !> - November, 2013- Initial Version 578 !> @date November, 2013 - Initial Version 579 !> @date February, 2015 - create unused dimension, when reading dimension 580 !> of length less or equal to zero 570 581 ! 571 582 !> @param[in] td_file file structure … … 583 594 INTEGER(i4) :: il_len 584 595 CHARACTER(LEN=lc) :: cl_name 596 LOGICAL :: ll_use 585 597 !---------------------------------------------------------------- 586 598 … … 601 613 il_status=NF90_INQUIRE_DIMENSION(td_file%i_id, id_dimid, & 602 614 & cl_name, il_len ) 603 CALL iom_cdf__check(il_status) 604 605 iom_cdf__read_dim_id=dim_init(cl_name, il_len) 615 CALL iom_cdf__check(il_status,"IOM CDF READ DIM: ") 616 617 ll_use=.TRUE. 618 IF( il_len <= 0 )THEN 619 CALL logger_warn( & 620 & " IOM CDF READ DIM: dimension "//TRIM(fct_str(id_dimid))//& 621 & " in file "//TRIM(td_file%c_name)//" is less or equel to zero") 622 il_len=1 623 ll_use=.FALSE. 624 ENDIF 625 iom_cdf__read_dim_id=dim_init(cl_name, il_len, ld_use=ll_use) 606 626 607 627 ENDIF … … 613 633 ! 614 634 !> @author J.Paul 615 !> - November, 2013- Initial Version635 !> @date November, 2013 - Initial Version 616 636 ! 617 637 !> @param[in] td_file file structure … … 634 654 635 655 CALL logger_error( & 636 & " IOM CDF READ DIM: no id associated to file "//TRIM(td_file%c_name)) 656 & " IOM CDF READ DIM: no id associated to file "//& 657 & TRIM(td_file%c_name)) 637 658 638 659 ELSE … … 640 661 il_status=NF90_INQ_DIMID( td_file%i_id, TRIM(ADJUSTL(cd_name)), & 641 662 & il_dimid) 642 CALL iom_cdf__check(il_status )663 CALL iom_cdf__check(il_status,"IOM CDF READ DIM: ") 643 664 644 665 iom_cdf__read_dim_name=iom_cdf_read_dim(td_file, il_dimid) … … 652 673 ! 653 674 !> @author J.Paul 654 !> - November, 2013- Initial Version675 !> @date November, 2013 - Initial Version 655 676 ! 656 677 !> @param[in] td_file file structure … … 714 735 & il_len, & 715 736 & il_attid ) 716 CALL iom_cdf__check(il_status )737 CALL iom_cdf__check(il_status,"IOM CDF READ ATT: ") 717 738 718 739 !! get attribute value 719 CALL logger_debug( " IOM CDF READ ATT: get attribute "// TRIM(cl_name)//&720 &" in file "//TRIM(td_file%c_name))740 CALL logger_debug( " IOM CDF READ ATT: get attribute "//& 741 & TRIM(cl_name)//" in file "//TRIM(td_file%c_name)) 721 742 722 743 SELECT CASE( il_type ) … … 728 749 729 750 CALL logger_error( & 730 & " IOM CDF READ ATT: not enough space to put attribute"//&731 & TRIM(cl_name) )751 & " IOM CDF READ ATT: not enough space to put "//& 752 & "attribute "//TRIM(cl_name) ) 732 753 733 754 ELSE … … 737 758 & cl_name, & 738 759 & cl_value ) 739 CALL iom_cdf__check(il_status )760 CALL iom_cdf__check(il_status,"IOM CDF READ ATT: ") 740 761 741 762 iom_cdf__read_att_name=att_init(cl_name, cl_value) … … 758 779 & cl_name, & 759 780 & bl_value(:)) 760 CALL iom_cdf__check(il_status )781 CALL iom_cdf__check(il_status,"IOM CDF READ ATT: ") 761 782 762 783 iom_cdf__read_att_name=att_init(cl_name, bl_value(:)) … … 773 794 774 795 CALL logger_error( & 775 & " IOM CDF READ ATT: not enough space to put attribute"//&776 & TRIM(cl_name) )796 & " IOM CDF READ ATT: not enough space to put "//& 797 & "attribute "//TRIM(cl_name) ) 777 798 778 799 ELSE … … 782 803 & cl_name, & 783 804 & sl_value(:)) 784 CALL iom_cdf__check(il_status )805 CALL iom_cdf__check(il_status,"IOM CDF READ ATT: ") 785 806 786 807 iom_cdf__read_att_name=att_init(cl_name, sl_value(:)) … … 797 818 798 819 CALL logger_error( & 799 & " IOM CDF READ ATT: not enough space to put attribute"//&800 & TRIM(cl_name) )820 & " IOM CDF READ ATT: not enough space to put "//& 821 & "attribute "//TRIM(cl_name) ) 801 822 802 823 ELSE … … 806 827 & cl_name, & 807 828 & il_value(:)) 808 CALL iom_cdf__check(il_status )829 CALL iom_cdf__check(il_status,"IOM CDF READ ATT: ") 809 830 810 831 iom_cdf__read_att_name=att_init(cl_name, il_value(:)) … … 820 841 821 842 CALL logger_error( & 822 & " IOM CDF READ ATT: not enough space to put attribute"//&823 & TRIM(cl_name) )843 & " IOM CDF READ ATT: not enough space to put "//& 844 & "attribute "//TRIM(cl_name) ) 824 845 825 846 ELSE … … 829 850 & cl_name, & 830 851 & fl_value(:)) 831 CALL iom_cdf__check(il_status )852 CALL iom_cdf__check(il_status,"IOM CDF READ ATT: ") 832 853 833 854 iom_cdf__read_att_name=att_init(cl_name, fl_value(:)) … … 844 865 845 866 CALL logger_error( & 846 & " IOM CDF READ ATT: not enough space to put attribute"//&847 & TRIM(cl_name) )867 & " IOM CDF READ ATT: not enough space to put "//& 868 & "attribute "//TRIM(cl_name) ) 848 869 849 870 ELSE … … 853 874 & cl_name, & 854 875 & dl_value(:)) 855 CALL iom_cdf__check(il_status )876 CALL iom_cdf__check(il_status,"IOM CDF READ ATT: ") 856 877 857 878 iom_cdf__read_att_name=att_init(cl_name, dl_value(:)) … … 873 894 ! 874 895 !> @author J.Paul 875 !> - November, 2013- Initial Version896 !> @date November, 2013 - Initial Version 876 897 ! 877 898 !> @param[in] td_file file structure … … 902 923 ! get attribute name 903 924 il_status=NF90_INQ_ATTNAME(td_file%i_id, id_varid, id_attid, cl_name) 904 CALL iom_cdf__check(il_status )925 CALL iom_cdf__check(il_status,"IOM CDF READ ATT: ") 905 926 906 927 ! read attribute … … 918 939 ! 919 940 !> @author J.Paul 920 !> - November, 2013- Initial Version941 !> @date November, 2013 - Initial Version 921 942 ! 922 943 !> @param[in] td_file file structure … … 976 997 ! 977 998 !> @author J.Paul 978 !> - November, 2013- Initial Version999 !> @date November, 2013 - Initial Version 979 1000 ! 980 1001 !> @param[in] td_file file structure … … 1043 1064 ! 1044 1065 !> @author J.Paul 1045 !> - November, 2013- Initial Version1066 !> @date November, 2013 - Initial Version 1046 1067 ! 1047 1068 !> @param[inout] td_file file structure … … 1085 1106 ! 1086 1107 !> @author J.Paul 1087 !> - November, 2013- Initial Version1108 !> @date November, 2013 - Initial Version 1088 1109 ! 1089 1110 !> @param[inout] td_file file structure … … 1148 1169 ! 1149 1170 !> @author J.Paul 1150 !> - November, 2013- Initial Version1171 !> @date November, 2013 - Initial Version 1151 1172 ! 1152 1173 !> @param[inout] td_file file structure … … 1199 1220 ! 1200 1221 !> @author J.Paul 1201 !> - November, 2013- Initial Version1222 !> @date November, 2013 - Initial Version 1202 1223 !> @date September, 2014 1203 1224 !> - force to use FillValue=1.e20 if no FillValue for coordinate variable. … … 1240 1261 1241 1262 ! inquire variable 1242 CALL logger_ trace( &1263 CALL logger_debug( & 1243 1264 & " IOM CDF READ VAR META: inquire variable "//& 1244 1265 & TRIM(fct_str(id_varid))//& … … 1253 1274 & il_dimid(:),& 1254 1275 & il_natt ) 1255 CALL iom_cdf__check(il_status )1276 CALL iom_cdf__check(il_status,"IOM CDF READ VAR META: ") 1256 1277 !!! fill variable dimension structure 1257 1278 tl_dim(:)=iom_cdf__read_var_dim( td_file, il_ndim, il_dimid(:) ) 1279 1258 1280 IF( il_natt /= 0 )THEN 1259 1281 ALLOCATE( tl_att(il_natt) ) … … 1276 1298 ELSE 1277 1299 ! create attribute _FillValue 1278 SELECT CASE(TRIM( cl_name))1300 SELECT CASE(TRIM(fct_lower(cl_name))) 1279 1301 CASE DEFAULT 1280 1302 CALL logger_info("IOM CDF READ VAR META: assume _FillValue is equal to "//& 1281 1303 & "zero for variable "//TRIM(cl_name) ) 1282 1304 tl_fill=att_init('_FillValue',0.) 1283 CASE('nav_lon','nav_lat', &1305 CASE('nav_lon','nav_lat', 'nav_lev', & 1284 1306 & 'glamt','glamu','glamv','glamf', & 1285 1307 & 'gphit','gphiu','gphiv','gphif') … … 1311 1333 ALLOCATE(tl_att(il_natt+1) ) 1312 1334 ! create attribute _FillValue 1313 SELECT CASE(TRIM( cl_name))1335 SELECT CASE(TRIM(fct_lower(cl_name))) 1314 1336 CASE DEFAULT 1315 1337 CALL logger_info("IOM CDF READ VAR META: assume _FillValue is equal to "//& … … 1353 1375 ! 1354 1376 !> @author J.Paul 1355 !> - November, 2013- Initial Version 1356 ! 1377 !> @date November, 2013 - Initial Version 1378 !> @date July, 2015 1379 !> - Bug fix: use order to disorder table (see dim_init) 1380 !> 1357 1381 !> @param[in] td_file file structure 1358 1382 !> @param[in] id_ndim number of dimension … … 1371 1395 1372 1396 ! local variable 1373 INTEGER(i4), DIMENSION(ip_maxdim) :: il_ 2xyzt1397 INTEGER(i4), DIMENSION(ip_maxdim) :: il_xyzt2 1374 1398 1375 1399 TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim … … 1395 1419 1396 1420 DO ji = 1, id_ndim 1397 CALL logger_ trace( " IOM CDF READ VAR DIM: get variable dimension"//&1398 &TRIM(fct_str(ji)) )1399 1400 il_ 2xyzt(ji)=td_file%t_dim(id_dimid(ji))%i_2xyzt1421 CALL logger_debug( " IOM CDF READ VAR DIM: get variable "//& 1422 & "dimension "//TRIM(fct_str(ji)) ) 1423 1424 il_xyzt2(ji)=td_file%t_dim(id_dimid(ji))%i_xyzt2 1401 1425 1402 1426 ! read dimension information 1403 tl_dim(ji) = dim_init( td_file%t_dim(il_ 2xyzt(ji))%c_name, &1404 & td_file%t_dim(il_ 2xyzt(ji))%i_len )1427 tl_dim(ji) = dim_init( td_file%t_dim(il_xyzt2(ji))%c_name, & 1428 & td_file%t_dim(il_xyzt2(ji))%i_len ) 1405 1429 ENDDO 1406 1430 1407 1431 ! reorder dimension to ('x','y','z','t') 1408 1432 CALL dim_reorder(tl_dim(:)) 1409 1433 1410 1434 iom_cdf__read_var_dim(:)=dim_copy(tl_dim(:)) 1411 1435 … … 1426 1450 ! 1427 1451 !> @author J.Paul 1428 !> - November, 2013- Initial Version1452 !> @date November, 2013 - Initial Version 1429 1453 ! 1430 1454 !> @param[in] td_file file structure … … 1475 1499 ! 1476 1500 !> @author J.Paul 1477 !> - November, 2013- Initial Version 1501 !> @date November, 2013 - Initial Version 1502 !> @date June, 2015 1503 !> - use scale factor and offset, as soon as read variable value 1478 1504 ! 1479 1505 !> @param[in] td_file file structure … … 1482 1508 !> @param[in] id_count number of indices selected along each dimension 1483 1509 !> @return variable structure completed 1484 !1485 !> @todo1486 !> - warning do not change fill value when use scale factor..1487 1510 !------------------------------------------------------------------- 1488 1511 SUBROUTINE iom_cdf__read_var_value(td_file, td_var, & … … 1496 1519 1497 1520 ! local variable 1498 INTEGER(i4) :: il_status 1499 INTEGER(i4) :: il_tmp1 1500 INTEGER(i4) :: il_tmp2 1501 INTEGER(i4) :: il_varid 1502 INTEGER(i4), DIMENSION(ip_maxdim) :: il_start 1503 INTEGER(i4), DIMENSION(ip_maxdim) :: il_count 1504 INTEGER(i4), DIMENSION(ip_maxdim) :: il_start_ord 1505 INTEGER(i4), DIMENSION(ip_maxdim) :: il_count_ord 1521 INTEGER(i4) :: il_status 1522 INTEGER(i4) :: il_tmp1 1523 INTEGER(i4) :: il_tmp2 1524 INTEGER(i4) :: il_varid 1525 INTEGER(i4), DIMENSION(ip_maxdim) :: il_start 1526 INTEGER(i4), DIMENSION(ip_maxdim) :: il_count 1527 INTEGER(i4), DIMENSION(ip_maxdim) :: il_start_ord 1528 INTEGER(i4), DIMENSION(ip_maxdim) :: il_count_ord 1529 1506 1530 REAL(dp) , DIMENSION(:,:,:,:) , ALLOCATABLE :: dl_value 1507 1531 REAL(dp) , DIMENSION(:,:,:,:) , ALLOCATABLE :: dl_tmp … … 1518 1542 IF( ( PRESENT(id_start) .AND. (.NOT. PRESENT(id_count))) .OR. & 1519 1543 ((.NOT. PRESENT(id_start)) .AND. PRESENT(id_count) ) )THEN 1520 CALL logger_warn( &1521 & "IOM CDF READ VAR VALUE: id_start and id_countshould be both specify")1544 CALL logger_warn( "IOM CDF READ VAR VALUE: id_start and id_count"//& 1545 & " should be both specify") 1522 1546 ENDIF 1523 1547 IF( PRESENT(id_start).AND.PRESENT(id_count) )THEN … … 1525 1549 IF( SIZE(id_start(:)) /= ip_maxdim .OR. & 1526 1550 & SIZE(id_count(:)) /= ip_maxdim )THEN 1527 CALL logger_error("IOM CDF READ VAR: dimension of array start or count"//&1528 & " are invalid to read variable "//TRIM(td_var%c_name)//&1529 &" in file "//TRIM(td_file%c_name) )1551 CALL logger_error("IOM CDF READ VAR: dimension of array start"//& 1552 & " or count are invalid to read variable "//& 1553 & TRIM(td_var%c_name)//" in file "//TRIM(td_file%c_name) ) 1530 1554 ENDIF 1531 1555 … … 1564 1588 & td_var%t_dim( 4 )%i_len & 1565 1589 & /)) )THEN 1566 1567 CALL logger_error( "IOM CDF READ VAR VALUE: start + count exceed "//&1568 & "variable dimension for "//TRIM(td_var%c_name) )1569 1590 1570 1591 DO ji = 1, ip_maxdim … … 1575 1596 & TRIM(fct_str(il_tmp2))) 1576 1597 ENDDO 1598 CALL logger_error( "IOM CDF READ VAR VALUE: start + count exceed "//& 1599 & "variable dimension for "//TRIM(td_var%c_name) ) 1577 1600 1578 1601 ELSE 1579 1602 1580 ! Allocate space to hold variable value ( unorder)1603 ! Allocate space to hold variable value (disorder) 1581 1604 ALLOCATE(dl_value( il_count(1), & 1582 1605 & il_count(2), & … … 1601 1624 & start = il_start(:),& 1602 1625 & count = il_count(:) ) 1603 CALL iom_cdf__check(il_status )1626 CALL iom_cdf__check(il_status,"IOM CDF READ VAR VALUE: ") 1604 1627 1605 1628 ! Allocate space to hold variable value in structure … … 1663 1686 CALL var_chg_FillValue(td_var) 1664 1687 ENDIF 1688 1689 ! use scale factor and offset 1690 WHERE( td_var%d_value(:,:,:,:) /= td_var%d_fill ) 1691 td_var%d_value(:,:,:,:) = & 1692 & td_var%d_value(:,:,:,:)*td_var%d_scf + td_var%d_ofs 1693 END WHERE 1694 1665 1695 ENDIF 1666 1696 ELSE … … 1673 1703 !------------------------------------------------------------------- 1674 1704 !> @brief This subroutine write file structure in an opened netcdf file. 1675 ! 1676 !> @author J.Paul 1677 !> - November, 2013- Initial Version 1705 !> 1706 !> @details 1707 !> optionally, you could specify dimension order (default 'xyzt') 1708 !> 1709 !> @author J.Paul 1710 !> @date November, 2013 - Initial Version 1711 !> @date July, 2015 1712 !> - add dimension order option 1678 1713 ! 1679 1714 !> @param[inout] td_file file structure 1680 1715 !------------------------------------------------------------------- 1681 SUBROUTINE iom_cdf_write_file(td_file) 1682 IMPLICIT NONE 1683 ! Argument 1684 TYPE(TFILE), INTENT(INOUT) :: td_file 1716 SUBROUTINE iom_cdf_write_file(td_file, cd_dimorder) 1717 IMPLICIT NONE 1718 ! Argument 1719 TYPE(TFILE) , INTENT(INOUT) :: td_file 1720 CHARACTER(LEN=*), INTENT(IN ), OPTIONAL :: cd_dimorder 1685 1721 1686 1722 ! local variable 1687 1723 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_value 1724 1725 CHARACTER(LEN=lc) :: cl_dimorder 1688 1726 1689 1727 TYPE(TVAR) :: tl_var … … 1694 1732 INTEGER(i4) :: ji 1695 1733 INTEGER(i4) :: jj 1696 !---------------------------------------------------------------- 1734 INTEGER(i4) :: jvar 1735 !---------------------------------------------------------------- 1736 1737 cl_dimorder='xyzt' 1738 IF( PRESENT(cd_dimorder) ) cl_dimorder=TRIM(cd_dimorder) 1697 1739 1698 1740 ! check if file opened … … 1726 1768 ENDIF 1727 1769 1770 ! change dimension order 1771 IF( TRIM(cl_dimorder) /= 'xyzt' )THEN 1772 CALL dim_reorder(td_file%t_dim(:),TRIM(cl_dimorder)) 1773 DO jvar=1,td_file%i_nvar 1774 CALL logger_debug("VAR REORDER: "//TRIM(td_file%t_var(jvar)%c_name)) 1775 CALL var_reorder(td_file%t_var(jvar),TRIM(cl_dimorder)) 1776 ENDDO 1777 ENDIF 1778 1728 1779 ! write dimension in file 1729 1780 DO ji = 1, ip_maxdim … … 1776 1827 ! 1777 1828 !> @author J.Paul 1778 !> - November, 2013- Initial Version1829 !> @date November, 2013 - Initial Version 1779 1830 ! 1780 1831 !> @param[inout] td_file file structure … … 1798 1849 ! Enter define mode 1799 1850 il_status=NF90_REDEF(td_file%i_id) 1800 CALL iom_cdf__check(il_status )1851 CALL iom_cdf__check(il_status,"IOM CDF WRITE FILE DIM: ") 1801 1852 1802 1853 td_file%l_def=.TRUE. … … 1813 1864 il_status=NF90_DEF_DIM(td_file%i_id, fct_upper(td_dim%c_sname), & 1814 1865 & NF90_UNLIMITED, td_dim%i_id) 1815 CALL iom_cdf__check(il_status )1866 CALL iom_cdf__check(il_status,"IOM CDF WRITE FILE DIM: ") 1816 1867 1817 1868 ELSE 1818 1869 ! write not unlimited dimension 1819 CALL logger_ trace( &1870 CALL logger_debug( & 1820 1871 & "IOM CDF WRITE FILE DIM: write dimension "//TRIM(td_dim%c_name)//& 1821 1872 & " in file "//TRIM(td_file%c_name)) … … 1823 1874 il_status=NF90_DEF_DIM(td_file%i_id, fct_upper(td_dim%c_sname), & 1824 1875 & td_dim%i_len, td_dim%i_id) 1825 CALL iom_cdf__check(il_status )1876 CALL iom_cdf__check(il_status,"IOM CDF WRITE FILE DIM: ") 1826 1877 1827 1878 ENDIF … … 1834 1885 ! 1835 1886 !> @author J.Paul 1836 !> - November, 2013- Initial Version1887 !> @date November, 2013 - Initial Version 1837 1888 ! 1838 1889 !> @param[inout] td_file file structure … … 1859 1910 ! Enter define mode 1860 1911 il_status=NF90_REDEF(td_file%i_id) 1861 CALL iom_cdf__check(il_status )1912 CALL iom_cdf__check(il_status,"IOM CDF WRITE FILE ATT: ") 1862 1913 1863 1914 td_file%l_def=.TRUE. … … 1876 1927 il_status = NF90_PUT_ATT(td_file%i_id, id_varid, & 1877 1928 & td_att%c_name, td_att%c_value ) 1878 CALL iom_cdf__check(il_status )1929 CALL iom_cdf__check(il_status,"IOM CDF WRITE FILE ATT: ") 1879 1930 1880 1931 CASE(NF90_BYTE, NF90_SHORT, NF90_INT, NF90_FLOAT, NF90_DOUBLE) … … 1882 1933 il_status = NF90_PUT_ATT(td_file%i_id, id_varid, & 1883 1934 & td_att%c_name, td_att%d_value ) 1884 CALL iom_cdf__check(il_status )1935 CALL iom_cdf__check(il_status,"IOM CDF WRITE FILE ATT: ") 1885 1936 1886 1937 END SELECT … … 1891 1942 ! 1892 1943 !> @author J.Paul 1893 !> - November, 2013- Initial Version1944 !> @date November, 2013 - Initial Version 1894 1945 ! 1895 1946 !> @param[inout] td_file file structure … … 1917 1968 ! Enter define mode 1918 1969 il_status=NF90_REDEF(td_file%i_id) 1919 CALL iom_cdf__check(il_status )1970 CALL iom_cdf__check(il_status,"IOM CDF WRITE VAR: ") 1920 1971 1921 1972 td_file%l_def=.TRUE. 1922 1973 1923 1974 ENDIF 1924 1975 1925 1976 ! check if file and variable dimension conform 1926 1977 IF( file_check_var_dim(td_file, td_var) )THEN … … 1938 1989 ENDIF 1939 1990 ENDDO 1991 ! ugly patch until NEMO do not force to use 0. as FillValue 1940 1992 IF( ll_chg )THEN 1941 1993 ! not a dimension variable 1942 1994 ! change FillValue 1943 1944 ! ugly patch until NEMO do not force to use 0. as FillValue 1945 CALL var_chg_FillValue(td_var,0._dp) 1995 SELECT CASE( TRIM(fct_lower(td_var%c_name)) ) 1996 CASE DEFAULT 1997 CALL var_chg_FillValue(td_var,0._dp) 1998 CASE('nav_lon','nav_lat', & 1999 & 'glamt','glamu','glamv','glamf', & 2000 & 'gphit','gphiu','gphiv','gphif') 2001 END SELECT 1946 2002 ENDIF 1947 2003 … … 1957 2013 ! Leave define mode 1958 2014 il_status=NF90_ENDDEF(td_file%i_id) 1959 CALL iom_cdf__check(il_status )2015 CALL iom_cdf__check(il_status,"IOM CDF WRITE VAR: ") 1960 2016 1961 2017 td_file%l_def=.FALSE. … … 1975 2031 ! 1976 2032 !> @author J.Paul 1977 !> - November, 2013- Initial Version2033 !> @date November, 2013 - Initial Version 1978 2034 ! 1979 2035 !> @param[in] td_file file structure … … 2002 2058 tl_var=var_copy(td_var) 2003 2059 2060 ! forced to use float type 2061 IF( tl_var%d_unf /= 1. .AND. tl_var%i_type==NF90_SHORT )THEN 2062 tl_var%i_type=NF90_FLOAT 2063 ENDIF 2064 2004 2065 IF( ALL( .NOT. tl_var%t_dim(:)%l_use ) )THEN 2066 CALL logger_debug( & 2067 & "IOM CDF WRITE VAR DEF scalar: define variable "//& 2068 & TRIM(tl_var%c_name)//" in file "//TRIM(td_file%c_name)) 2005 2069 ! scalar value 2006 2070 il_status = NF90_DEF_VAR(td_file%i_id, TRIM(tl_var%c_name), & 2007 2071 & tl_var%i_type, varid=iom_cdf__write_var_def) 2008 CALL iom_cdf__check(il_status )2072 CALL iom_cdf__check(il_status,"IOM CDF WRITE VAR DEF: ") 2009 2073 ELSE 2010 2074 … … 2020 2084 ENDDO 2021 2085 2022 CALL logger_ trace( &2086 CALL logger_debug( & 2023 2087 & "IOM CDF WRITE VAR DEF: define dimension to be used for variable "//& 2024 2088 & TRIM(tl_var%c_name)//" in file "//TRIM(td_file%c_name)) 2025 2089 2026 2090 DO ji=1,jj 2027 CALL logger_ trace("IOM CDF WRITE VAR DEF: dimid "//TRIM(fct_str(il_dimid(ji))) )2091 CALL logger_debug("IOM CDF WRITE VAR DEF: dimid "//TRIM(fct_str(il_dimid(ji))) ) 2028 2092 ENDDO 2093 2029 2094 il_status = NF90_DEF_VAR(td_file%i_id, TRIM(tl_var%c_name), & 2030 2095 & tl_var%i_type, & 2031 2096 & il_dimid(1:jj), & 2032 2097 & varid=iom_cdf__write_var_def ) 2033 CALL iom_cdf__check(il_status )2098 CALL iom_cdf__check(il_status,"IOM CDF WRITE VAR DEF: ") 2034 2099 ENDIF 2035 2100 … … 2043 2108 2044 2109 DO ji = 1, tl_var%i_natt 2045 CALL logger_ trace( &2110 CALL logger_debug( & 2046 2111 & " IOM CDF WRITE VAR DEF: put attribute "//TRIM(tl_var%t_att(ji)%c_name)//& 2047 2112 & " for variable "//TRIM(tl_var%c_name)//& 2048 2113 & " in file "//TRIM(td_file%c_name) ) 2114 2115 ! forced FillValue to have same type than variable 2116 IF( TRIM(tl_var%t_att(ji)%c_name) == '_FillValue' )THEN 2117 tl_var%t_att(ji)%i_type=tl_var%i_type 2118 ENDIF 2049 2119 2050 2120 IF( tl_var%t_att(ji)%i_type == NF90_CHAR )THEN … … 2053 2123 & TRIM(tl_var%t_att(ji)%c_name), & 2054 2124 & TRIM(tl_var%t_att(ji)%c_value) ) 2055 CALL iom_cdf__check(il_status )2125 CALL iom_cdf__check(il_status,"IOM CDF WRITE VAR DEF: ") 2056 2126 ENDIF 2057 2127 ELSE … … 2082 2152 & TRIM(tl_var%t_att(ji)%c_name), & 2083 2153 & REAL(tl_var%t_att(ji)%d_value(:),dp)) 2084 2085 CALL iom_cdf__check(il_status )2154 END SELECT 2155 CALL iom_cdf__check(il_status,"IOM CDF WRITE VAR DEF: ") 2086 2156 ENDIF 2087 2157 ENDDO … … 2097 2167 ! 2098 2168 !> @author J.Paul 2099 !> - November, 2013- Initial Version 2169 !> @date November, 2013 - Initial Version 2170 !> @date June, 2015 2171 !> - reuse scale factor and offset, before writing variable 2100 2172 ! 2101 2173 !> @param[in] td_file file structure … … 2122 2194 & "IOM CDF WRITE VAR VALUE: get dimension to be used for variable "//& 2123 2195 & TRIM(td_var%c_name)//" in file "//TRIM(td_file%c_name)) 2124 2196 2197 ! use scale factor and offset 2198 WHERE( td_var%d_value(:,:,:,:) /= td_var%d_fill ) 2199 td_var%d_value(:,:,:,:) = & 2200 & (td_var%d_value(:,:,:,:)-td_var%d_ofs)/td_var%d_scf 2201 END WHERE 2202 2125 2203 jj=0 2126 2204 DO ji = 1, ip_maxdim … … 2153 2231 2154 2232 il_status = NF90_PUT_VAR( td_file%i_id, td_var%i_id, dl_value(:,:,:,:)) 2155 CALL iom_cdf__check(il_status )2233 CALL iom_cdf__check(il_status,"IOM CDF WRITE VAR VALUE: ") 2156 2234 2157 2235 DEALLOCATE( dl_value ) -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/iom_dom.f90
r5037 r6487 71 71 !> 72 72 !> @author J.Paul 73 !> - October, 2014- Initial Version73 !> @date October, 2014 - Initial Version 74 74 ! 75 75 !> @param[inout] td_mpp mpp structure … … 106 106 !> 107 107 !> @author J.Paul 108 !> - October, 2014- Initial Version108 !> @date October, 2014 - Initial Version 109 109 ! 110 110 !> @param[in] td_mpp mpp structure … … 130 130 !> 131 131 !> @author J.Paul 132 !> - October, 2014- Initial Version132 !> @date October, 2014 - Initial Version 133 133 !> 134 134 !> @param[in] td_mpp mpp structure … … 194 194 ! 195 195 !> @author J.Paul 196 !> - October, 2014- Initial Version196 !> @date October, 2014 - Initial Version 197 197 ! 198 198 !> @param[in] td_mpp mpp structure … … 246 246 !> 247 247 !> @author J.Paul 248 !> - October, 2014- Initial Version248 !> @date October, 2014 - Initial Version 249 249 !> 250 250 !> @todo … … 411 411 !> 412 412 !> @author J.Paul 413 !> - October, 2014- Initial Version413 !> @date October, 2014 - Initial Version 414 414 ! 415 415 !> @param[in] td_mpp mpp structure … … 465 465 !> 466 466 !> @author J.Paul 467 !> - October, 2014- Initial Version467 !> @date October, 2014 - Initial Version 468 468 !> 469 469 !> @param[in] td_mpp mpp structure … … 524 524 !> 525 525 !> @author J.Paul 526 !> - October, 2014- Initial Version526 !> @date October, 2014 - Initial Version 527 527 !> 528 528 !> @param[in] td_mpp mpp structure … … 636 636 !> 637 637 !> @author J.Paul 638 !> - October, 2014- Initial Version638 !> @date October, 2014 - Initial Version 639 639 ! 640 640 !> @param[in] td_mpp mpp structure … … 663 663 !> 664 664 !> @author J.Paul 665 !> - October, 2014- Initial Version665 !> @date October, 2014 - Initial Version 666 666 ! 667 667 !> @param[in] td_mpp mpp structure … … 691 691 !> 692 692 !> @author J.Paul 693 !> - October, 2014- Initial Version693 !> @date October, 2014 - Initial Version 694 694 ! 695 695 !> @param[in] td_mpp mpp structure -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/iom_mpp.f90
r5037 r6487 87 87 !> J.Paul 88 88 ! REVISION HISTORY: 89 !> @date Nov , 2013 - Initial Version89 !> @date November, 2013 - Initial Version 90 90 !> 91 91 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 137 137 !> 138 138 !> @author J.Paul 139 !> - November, 2013- Initial Version139 !> @date November, 2013 - Initial Version 140 140 ! 141 141 !> @param[inout] td_mpp mpp structure … … 161 161 162 162 ELSE 163 ! 164 td_mpp%i_id=1 165 163 166 ! if no processor file selected 164 167 ! force to open all files … … 221 224 !> 222 225 !> @author J.Paul 223 !> - November, 2013- Initial Version226 !> @date November, 2013 - Initial Version 224 227 ! 225 228 !> @param[inout] td_mpp mpp structure … … 248 251 !> 249 252 !> @author J.Paul 250 !> - November, 2013- Initial Version253 !> @date November, 2013 - Initial Version 251 254 ! 252 255 !> @param[in] td_mpp mpp structure … … 267 270 268 271 ELSE 272 ! 273 td_mpp%i_id=0 274 269 275 DO ji=1,td_mpp%i_nproc 270 276 IF( td_mpp%t_proc(ji)%i_id /= 0 )THEN … … 285 291 !> 286 292 !> @author J.Paul 287 !> - November, 2013- Initial Version293 !> @date November, 2013 - Initial Version 288 294 !> @date October, 2014 289 295 !> - use start and count array instead of domain structure. … … 314 320 & " in mpp strcuture "//TRIM(td_mpp%c_name)) 315 321 322 ELSEIF( td_mpp%i_id == 0 )THEN 323 324 CALL logger_error( " IOM MPP READ VAR: mpp structure not opened. "//& 325 & " can not read variable in "//TRIM(td_mpp%c_name)) 326 316 327 ELSE 328 317 329 318 330 IF( ANY(td_mpp%t_proc(:)%i_id /= 0) )THEN … … 355 367 ! 356 368 !> @author J.Paul 357 !> - November, 2013- Initial Version369 !> @date November, 2013 - Initial Version 358 370 !> @date October, 2014 359 371 !> - use start and count array instead of domain structure. … … 384 396 & " in mpp strcuture "//TRIM(td_mpp%c_name)) 385 397 398 ELSEIF( td_mpp%i_id == 0 )THEN 399 400 CALL logger_error( " IOM MPP READ VAR: mpp structure not opened. "//& 401 & " can not read variable in "//TRIM(td_mpp%c_name)) 402 386 403 ELSE 387 404 … … 400 417 CALL logger_error( & 401 418 & " IOM MPP READ VAR: there is no variable with "//& 402 & "name or standard name "//TRIM(cd_name)//&419 & "name or standard name "//TRIM(cd_name)//& 403 420 & " in processor/file "//TRIM(td_mpp%t_proc(1)%c_name)) 404 421 ENDIF … … 416 433 ! 417 434 !> @author J.Paul 418 !> - November, 2013- Initial Version435 !> @date November, 2013 - Initial Version 419 436 !> @date October, 2014 420 437 !> - use start and count array instead of domain structure. … … 467 484 IF( PRESENT(id_count) ) il_count(:)=id_count(:) 468 485 486 CALL logger_debug("IOM MPP READ VAR VALUE: start "//& 487 & TRIM(fct_str(il_start(jp_I)))//","//& 488 & TRIM(fct_str(il_start(jp_J)))//","//& 489 & TRIM(fct_str(il_start(jp_K)))//","//& 490 & TRIM(fct_str(il_start(jp_L))) ) 491 CALL logger_debug("IOM MPP READ VAR VALUE: count "//& 492 & TRIM(fct_str(il_count(jp_I)))//","//& 493 & TRIM(fct_str(il_count(jp_J)))//","//& 494 & TRIM(fct_str(il_count(jp_K)))//","//& 495 & TRIM(fct_str(il_count(jp_L))) ) 496 469 497 DO jk=1,ip_maxdim 470 498 IF( .NOT. td_var%t_dim(jk)%l_use )THEN … … 476 504 ENDDO 477 505 478 479 506 IF( ANY(il_end(:) > td_mpp%t_dim(:)%i_len) )THEN 507 CALL logger_debug("IOM MPP READ VAR VALUE: start + count "//& 508 & TRIM(fct_str(il_end(jp_I)))//","//& 509 & TRIM(fct_str(il_end(jp_J)))//","//& 510 & TRIM(fct_str(il_end(jp_K)))//","//& 511 & TRIM(fct_str(il_end(jp_L))) ) 512 CALL logger_debug("IOM MPP READ VAR VALUE: dimension "//& 513 & TRIM(fct_str(td_mpp%t_dim(jp_I)%i_len))//","//& 514 & TRIM(fct_str(td_mpp%t_dim(jp_J)%i_len))//","//& 515 & TRIM(fct_str(td_mpp%t_dim(jp_K)%i_len))//","//& 516 & TRIM(fct_str(td_mpp%t_dim(jp_L)%i_len)) ) 480 517 CALL logger_fatal("IOM MPP READ VAR VALUE: start + count "//& 481 518 & "exceed dimension bound.") … … 583 620 ! 584 621 !> @details 622 !> optionally, you could specify the dimension order (default 'xyzt') 585 623 ! 586 624 !> @author J.Paul 587 !> - November, 2013- Initial Version 625 !> @date November, 2013 - Initial Version 626 !> @date July, 2015 - add dimension order option 588 627 ! 589 628 !> @param[inout] td_mpp mpp structure 590 !------------------------------------------------------------------- 591 SUBROUTINE iom_mpp_write_file(td_mpp) 629 !> @param[In] cd_dimorder dimension order 630 !------------------------------------------------------------------- 631 SUBROUTINE iom_mpp_write_file(td_mpp, cd_dimorder) 592 632 IMPLICIT NONE 593 633 ! Argument 594 TYPE(TMPP), INTENT(INOUT) :: td_mpp 634 TYPE(TMPP) , INTENT(INOUT) :: td_mpp 635 CHARACTER(LEN=*), INTENT(IN ), OPTIONAL :: cd_dimorder 595 636 596 637 ! local variable … … 610 651 !CALL file_del_att(td_mpp%t_proc(ji), 'ew_overlap') 611 652 612 CALL iom_write_file(td_mpp%t_proc(ji) )653 CALL iom_write_file(td_mpp%t_proc(ji), cd_dimorder) 613 654 ELSE 614 655 CALL logger_debug( " MPP WRITE: no id associated to file "//& -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/iom_rstdimg.f90
r5037 r6487 131 131 !> 132 132 !> @author J.Paul 133 !> - November, 2013- Initial Version133 !> @date November, 2013 - Initial Version 134 134 ! 135 135 !> @param[inout] td_file file structure … … 284 284 !> 285 285 !> @author J.Paul 286 !> - November, 2013- Initial Version286 !> @date November, 2013 - Initial Version 287 287 ! 288 288 !> @param[inout] td_file file structure … … 328 328 !> 329 329 !> @author J.Paul 330 !> - November, 2013- Initial Version330 !> @date November, 2013 - Initial Version 331 331 ! 332 332 !> @param[inout] td_file file structure … … 394 394 !> 395 395 !> @author J.Paul 396 !> - November, 2013- Initial Version396 !> @date November, 2013 - Initial Version 397 397 ! 398 398 !> @param[inout] td_file file structure … … 544 544 ! 545 545 !> @author J.Paul 546 !> - November, 2013- Initial Version546 !> @date November, 2013 - Initial Version 547 547 ! 548 548 !> @param[inout] td_file file structure … … 636 636 ! 637 637 !> @author J.Paul 638 !> - November, 2013- Initial Version638 !> @date November, 2013 - Initial Version 639 639 ! 640 640 !> @param[inout] td_file file structure … … 688 688 ! 689 689 !> @author J.Paul 690 !> - November, 2013- Initial Version690 !> @date November, 2013 - Initial Version 691 691 ! 692 692 !> @param[inout] td_file file structure … … 733 733 ! 734 734 !> @author J.Paul 735 !> - November, 2013- Initial Version735 !> @date November, 2013 - Initial Version 736 736 ! 737 737 !> @param[inout] td_file file structure … … 778 778 ! 779 779 !> @author J.Paul 780 !> - November, 2013- Initial Version780 !> @date November, 2013 - Initial Version 781 781 ! 782 782 !> @param[inout] td_file file structure … … 820 820 ! 821 821 !> @author J.Paul 822 !> - Nov, 2013- Initial Version822 !> @date November, 2013 - Initial Version 823 823 ! 824 824 !> @param[in] td_file file structure … … 863 863 ! 864 864 !> @author J.Paul 865 !> - Nov, 2013- Initial Version865 !> @date November, 2013 - Initial Version 866 866 ! 867 867 !> @param[in] td_file file structure … … 907 907 ! 908 908 !> @author J.Paul 909 !> - November, 2013- Initial Version909 !> @date November, 2013 - Initial Version 910 910 ! 911 911 !> @param[in] td_file file structure … … 972 972 ! 973 973 !> @author J.Paul 974 !> - November, 2013- Initial Version974 !> @date November, 2013 - Initial Version 975 975 ! 976 976 !> @param[in] td_file file structure … … 1037 1037 !> 1038 1038 !> @author J.Paul 1039 !> - November, 2013- Initial Version1039 !> @date November, 2013 - Initial Version 1040 1040 ! 1041 1041 !> @param[in] td_file file structure … … 1058 1058 INTEGER(i4), DIMENSION(ip_maxdim) :: il_start 1059 1059 INTEGER(i4), DIMENSION(ip_maxdim) :: il_count 1060 1060 1061 REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value 1061 1062 … … 1204 1205 ENDIF 1205 1206 1207 ! force to change _FillValue to avoid mistake 1208 ! with dummy zero _FillValue 1209 IF( td_var%d_fill == 0._dp )THEN 1210 CALL var_chg_FillValue(td_var) 1211 ENDIF 1212 1213 ! use scale factor and offset 1214 WHERE( td_var%d_value(:,:,:,:) /= td_var%d_fill ) 1215 td_var%d_value(:,:,:,:) = & 1216 & td_var%d_value(:,:,:,:)*td_var%d_scf + td_var%d_ofs 1217 END WHERE 1218 1206 1219 END SUBROUTINE iom_rstdimg__read_var_value 1207 1220 !------------------------------------------------------------------- … … 1212 1225 !> 1213 1226 !> @author J.Paul 1214 !> - November, 2013- Initial Version1227 !> @date November, 2013 - Initial Version 1215 1228 !> @date September, 2014 1216 1229 !> - use iom_rstdimg__get_rec … … 1308 1321 !> 1309 1322 !> @author J.Paul 1310 !> - September, 2014- Initial Version1323 !> @date September, 2014 - Initial Version 1311 1324 ! 1312 1325 !> @param[inout] td_file file structure … … 1413 1426 ! 1414 1427 !> @author J.Paul 1415 !> - November, 2013- Initial Version1428 !> @date November, 2013 - Initial Version 1416 1429 ! 1417 1430 !> @param[inout] td_file file structure … … 1630 1643 !> 1631 1644 !> @author J.Paul 1632 !> - November, 2013- Initial Version 1645 !> @date November, 2013 - Initial Version 1646 !> @date July, 2015 1647 !> - bug fix: do not use scale factor an offset for case no0d, no1d... 1633 1648 !> 1634 !> @param[in] id_fileid file id1649 !> @param[in] td_file file structure 1635 1650 !------------------------------------------------------------------- 1636 1651 SUBROUTINE iom_rstdimg__write_var(td_file) … … 1667 1682 CASE('no0d','no1d','no2d','no3d') 1668 1683 CASE DEFAULT 1684 1685 ! use scale factor and offset 1686 WHERE( td_file%t_var(ji)%d_value(:,:,:,:) /= & 1687 & td_file%t_var(ji)%d_fill ) 1688 td_file%t_var(ji)%d_value(:,:,:,:) = & 1689 & ( td_file%t_var(ji)%d_value(:,:,:,:) - & 1690 & td_file%t_var(ji)%d_ofs ) / & 1691 & td_file%t_var(ji)%d_scf 1692 END WHERE 1693 1669 1694 DO jk=1,td_file%t_var(ji)%t_dim(3)%i_len 1670 1695 SELECT CASE (td_file%t_var(ji)%i_ndim) -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/logger.f90
r5037 r6487 16 16 !> but not necessarily "wrong". 17 17 !> - error : Other runtime errors or unexpected conditions. 18 !> - fatal : Severe errors that cause premature termination. <br />18 !> - fatal : Severe errors that cause premature termination. 19 19 !> default verbosity is warning 20 !> - none : to not create and write any information in logger file.<br /> 20 21 ! 21 22 !> If total number of error exceeded maximum number … … 24 25 !> to open/create logger file:<br/> 25 26 !> @code 26 !> CALL logger_open(cd_file, [cd_verbosity,] [id_ loggerid,] [id_maxerror])27 !> CALL logger_open(cd_file, [cd_verbosity,] [id_maxerror,] [id_loggerid]) 27 28 !> @endcode 28 29 !> - cd_file is logger file name … … 120 121 !> J.Paul 121 122 ! REVISION HISTORY: 122 !> @date November, 2013- Initial Version 123 !> @date November, 2013 - Initial Version 124 !> @date February, 2015 125 !> - check verbosity validity 126 !> - add 'none' verbosity level to not used logger file 123 127 !> 124 128 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 151 155 152 156 PRIVATE :: logger__write ! cut message to get maximum of 80 character by line in log file 157 PRIVATE :: logger__check_verb! check verbosity validity 153 158 154 159 TYPE TLOGGER !< logger structure 155 160 INTEGER(i4) :: i_id = 0 !< log file id 161 LOGICAL :: l_use=.TRUE. !< use logger or not 156 162 CHARACTER(LEN=lc) :: c_name !< log file name 157 163 CHARACTER(LEN=lc) :: c_verbosity = "warning" !< verbosity choose … … 163 169 164 170 ! module variable 165 INTEGER(i4), PARAMETER :: im_nverbosity= 6!< number of log level171 INTEGER(i4), PARAMETER :: im_nverbosity=7 !< number of log level 166 172 CHARACTER(len=*), DIMENSION(im_nverbosity), PARAMETER :: cm_verbosity= & !< verbosity array 167 173 & (/ 'trace ',& … … 170 176 & 'warning ',& 171 177 & 'error ',& 172 & 'fatal '/) 178 & 'fatal ',& 179 & 'none '/) 173 180 174 181 TYPE(TLOGGER), SAVE :: tm_logger !< logger structure … … 184 191 !> 185 192 !> @author J.Paul 186 !> - November, 2013- Initial Version193 !> @date November, 2013 - Initial Version 187 194 ! 188 195 !> @param[in] cd_file log file name 189 196 !> @param[in] cd_verbosity log file verbosity 197 !> @param[in] id_maxerror maximum number of error 190 198 !> @param[in] id_logid log file id (use to flush) 191 !> @param[in] id_maxerror maximum number of error 192 !------------------------------------------------------------------- 193 SUBROUTINE logger_open(cd_file, cd_verbosity, id_logid, id_maxerror) 199 !------------------------------------------------------------------- 200 SUBROUTINE logger_open(cd_file, cd_verbosity, id_maxerror, id_logid) 194 201 IMPLICIT NONE 195 202 ! Argument 196 203 CHARACTER(len=*), INTENT(IN) :: cd_file ! log file name 197 204 CHARACTER(len=*), INTENT(IN), OPTIONAL :: cd_verbosity ! log file verbosity 205 INTEGER(i4), INTENT(IN), OPTIONAL :: id_maxerror ! log max error 198 206 INTEGER(i4), INTENT(IN), OPTIONAL :: id_logid ! log file id 199 INTEGER(i4), INTENT(IN), OPTIONAL :: id_maxerror ! log max error200 207 201 208 ! local variable 202 209 INTEGER(i4) :: il_status 203 210 211 LOGICAL :: ll_valid 212 204 213 ! loop 205 214 INTEGER(i4) :: ji 206 215 !---------------------------------------------------------------- 207 ! get id if not already define208 IF( PRESENT(id_logid) )THEN209 tm_logger%i_id=id_logid210 ELSE211 tm_logger%i_id=fct_getunit()212 ENDIF213 214 ! open log file215 OPEN( tm_logger%i_id, &216 & STATUS="unknown", &217 & FILE=TRIM(ADJUSTL(cd_file)), &218 & ACTION="write", &219 & POSITION="append", &220 & IOSTAT=il_status)221 CALL fct_err(il_status)222 223 ! keep filename224 tm_logger%c_name=TRIM(ADJUSTL(cd_file))225 216 226 217 ! if present, change verbosity value 227 218 IF( PRESENT(cd_verbosity) )THEN 228 tm_logger%c_verbosity=TRIM(ADJUSTL(cd_verbosity)) 229 ENDIF 230 231 ! compute "tab" of verbosity to be used 232 IF( TRIM(ADJUSTL(tm_logger%c_verb)) == "" )THEN 233 DO ji=im_nverbosity,1,-1 234 tm_logger%c_verb = & 235 & TRIM(tm_logger%c_verb)//" "//TRIM(ADJUSTL(cm_verbosity(ji))) 236 IF( TRIM(tm_logger%c_verbosity) == TRIM(cm_verbosity(ji)) )THEN 237 EXIT 238 ENDIF 239 ENDDO 240 ENDIF 241 242 IF( PRESENT(id_maxerror) )THEN 243 tm_logger%i_maxerror=id_maxerror 219 ll_valid=logger__check_verb(TRIM(ADJUSTL(cd_verbosity))) 220 IF( ll_valid )THEN 221 tm_logger%c_verbosity=TRIM(ADJUSTL(cd_verbosity)) 222 ENDIF 223 ENDIF 224 225 IF( TRIM(tm_logger%c_verbosity) == 'none' ) tm_logger%l_use=.FALSE. 226 227 IF( tm_logger%l_use )THEN 228 229 ! get id if not already define 230 IF( PRESENT(id_logid) )THEN 231 tm_logger%i_id=id_logid 232 ELSE 233 tm_logger%i_id=fct_getunit() 234 ENDIF 235 236 ! open log file 237 OPEN( tm_logger%i_id, & 238 & STATUS="unknown", & 239 & FILE=TRIM(ADJUSTL(cd_file)), & 240 & ACTION="write", & 241 & POSITION="append", & 242 & IOSTAT=il_status) 243 CALL fct_err(il_status) 244 245 ! keep filename 246 tm_logger%c_name=TRIM(ADJUSTL(cd_file)) 247 248 ! compute "tab" of verbosity to be used 249 IF( TRIM(ADJUSTL(tm_logger%c_verb)) == "" )THEN 250 DO ji=im_nverbosity,1,-1 251 tm_logger%c_verb = & 252 & TRIM(tm_logger%c_verb)//" "//TRIM(ADJUSTL(cm_verbosity(ji))) 253 IF( TRIM(tm_logger%c_verbosity) == TRIM(cm_verbosity(ji)) )THEN 254 EXIT 255 ENDIF 256 ENDDO 257 ENDIF 258 259 IF( PRESENT(id_maxerror) )THEN 260 tm_logger%i_maxerror=id_maxerror 261 ENDIF 262 244 263 ENDIF 245 264 … … 249 268 !> 250 269 !> @author J.Paul 251 !> - November, 2013- Initial Version270 !> @date November, 2013 - Initial Version 252 271 !------------------------------------------------------------------- 253 272 SUBROUTINE logger_close() … … 256 275 INTEGER(i4) :: il_status 257 276 !---------------------------------------------------------------- 258 IF( tm_logger%i_id /= 0 )THEN 259 tm_logger%i_id = 0 260 CLOSE( tm_logger%i_id, & 261 & IOSTAT=il_status) 262 CALL fct_err(il_status) 263 ELSE 264 CALL logger_open('logger.log') 265 CALL logger_header() 266 CALL logger_fatal('you must have create logger to use logger_close') 277 IF( tm_logger%l_use )THEN 278 IF( tm_logger%i_id /= 0 )THEN 279 tm_logger%i_id = 0 280 CLOSE( tm_logger%i_id, & 281 & IOSTAT=il_status) 282 CALL fct_err(il_status) 283 ELSE 284 CALL logger_open('logger.log') 285 CALL logger_header() 286 CALL logger_fatal('you must have create logger to use logger_close') 287 ENDIF 267 288 ENDIF 268 289 … … 272 293 !> 273 294 !> @author J.Paul 274 !> - November, 2013- Initial Version295 !> @date November, 2013 - Initial Version 275 296 !------------------------------------------------------------------- 276 297 SUBROUTINE logger_flush() 277 298 IMPLICIT NONE 278 299 !---------------------------------------------------------------- 279 IF( tm_logger%i_id /= 0 )THEN 280 CALL logger_close() 281 CALL logger_open( tm_logger%c_name, tm_logger%c_verbosity, tm_logger%i_id, & 282 & tm_logger%i_maxerror ) 283 ELSE 284 CALL logger_open('logger.log') 285 CALL logger_header() 286 CALL logger_fatal('you must have create logger to use logger_flush') 300 IF( tm_logger%l_use )THEN 301 IF( tm_logger%i_id /= 0 )THEN 302 CALL logger_close() 303 CALL logger_open( tm_logger%c_name, tm_logger%c_verbosity, & 304 & tm_logger%i_maxerror, tm_logger%i_id ) 305 ELSE 306 CALL logger_open('logger.log') 307 CALL logger_header() 308 CALL logger_fatal('you must have create logger to use logger_flush') 309 ENDIF 287 310 ENDIF 288 311 … … 292 315 !> 293 316 !> @author J.Paul 294 !> - November, 2013- Initial Version317 !> @date November, 2013 - Initial Version 295 318 !------------------------------------------------------------------- 296 319 RECURSIVE SUBROUTINE logger_header() … … 299 322 INTEGER(i4) :: il_status 300 323 !---------------------------------------------------------------- 301 IF( tm_logger%i_id /= 0 )THEN 302 WRITE( tm_logger%i_id, & 303 & FMT='(4(a/))', & 304 & IOSTAT=il_status ) & 305 & "--------------------------------------------------",& 306 & "INIT : verbosity "//TRIM(tm_logger%c_verbosity),& 307 & "INIT : max error "//TRIM(fct_str(tm_logger%i_maxerror)), & 308 & "--------------------------------------------------" 309 CALL fct_err(il_status) 310 ELSE 311 CALL logger_open('logger.log') 312 CALL logger_header() 313 CALL logger_fatal('you must have create logger to use logger_header') 324 IF( tm_logger%l_use )THEN 325 IF( tm_logger%i_id /= 0 )THEN 326 WRITE( tm_logger%i_id, & 327 & FMT='(4(a/))', & 328 & IOSTAT=il_status ) & 329 & "--------------------------------------------------",& 330 & "INIT : verbosity "//TRIM(tm_logger%c_verbosity),& 331 & "INIT : max error "//TRIM(fct_str(tm_logger%i_maxerror)), & 332 & "--------------------------------------------------" 333 CALL fct_err(il_status) 334 ELSE 335 CALL logger_open('logger.log') 336 CALL logger_header() 337 CALL logger_fatal('you must have create logger to use logger_header') 338 ENDIF 314 339 ENDIF 315 340 … … 319 344 !> 320 345 !> @author J.Paul 321 !> - November, 2013- Initial Version346 !> @date November, 2013 - Initial Version 322 347 !------------------------------------------------------------------- 323 348 SUBROUTINE logger_footer() … … 326 351 INTEGER(i4) :: il_status 327 352 !---------------------------------------------------------------- 328 IF( tm_logger%i_id /= 0 )THEN 329 WRITE( tm_logger%i_id, & 330 & FMT='(4(/a))', & 331 & IOSTAT=il_status ) & 332 & "--------------------------------------------------",& 333 & "END : log ended ", & 334 & "END : "//TRIM(fct_str(tm_logger%i_nerror))// & 335 & " ERROR detected ", & 336 & "END : "//TRIM(fct_str(tm_logger%i_nfatal))// & 337 & " FATAL detected ", & 338 & "--------------------------------------------------" 339 CALL fct_err(il_status) 340 ELSE 341 CALL logger_open('logger.log') 342 CALL logger_header() 343 CALL logger_fatal('you must have create logger to use logger_footer') 353 IF( tm_logger%l_use )THEN 354 IF( tm_logger%i_id /= 0 )THEN 355 WRITE( tm_logger%i_id, & 356 & FMT='(4(/a))', & 357 & IOSTAT=il_status ) & 358 & "--------------------------------------------------",& 359 & "END : log ended ", & 360 & "END : "//TRIM(fct_str(tm_logger%i_nerror))// & 361 & " ERROR detected ", & 362 & "END : "//TRIM(fct_str(tm_logger%i_nfatal))// & 363 & " FATAL detected ", & 364 & "--------------------------------------------------" 365 CALL fct_err(il_status) 366 ELSE 367 CALL logger_open('logger.log') 368 CALL logger_header() 369 CALL logger_fatal('you must have create logger to use logger_footer') 370 ENDIF 344 371 ENDIF 345 372 END SUBROUTINE logger_footer … … 350 377 !> 351 378 !> @author J.Paul 352 !> - November, 2013- Initial Version379 !> @date November, 2013 - Initial Version 353 380 ! 354 381 !> @param[in] cd_msg message to write … … 361 388 LOGICAL, INTENT(IN), OPTIONAL :: ld_flush 362 389 !---------------------------------------------------------------- 363 IF( tm_logger%i_id /= 0 )THEN 364 IF( INDEX(TRIM(tm_logger%c_verb),'trace')/=0 )THEN 365 366 CALL logger__write("TRACE :",cd_msg) 367 368 IF( PRESENT(ld_flush) )THEN 369 IF( ld_flush )THEN 370 CALL logger_flush() 371 ENDIF 372 ENDIF 373 ENDIF 374 ELSE 375 CALL logger_open('logger.log') 376 CALL logger_header() 377 CALL logger_fatal('you must have create logger to use logger_trace') 390 IF( tm_logger%l_use )THEN 391 IF( tm_logger%i_id /= 0 )THEN 392 IF( INDEX(TRIM(tm_logger%c_verb),'trace')/=0 )THEN 393 394 CALL logger__write("TRACE :",cd_msg) 395 396 IF( PRESENT(ld_flush) )THEN 397 IF( ld_flush )THEN 398 CALL logger_flush() 399 ENDIF 400 ENDIF 401 ENDIF 402 ELSE 403 CALL logger_open('logger.log') 404 CALL logger_header() 405 CALL logger_fatal('you must have create logger to use logger_trace') 406 ENDIF 378 407 ENDIF 379 408 END SUBROUTINE logger_trace … … 384 413 !> 385 414 !> @author J.Paul 386 !> - November, 2013- Initial Version415 !> @date November, 2013 - Initial Version 387 416 ! 388 417 !> @param[in] cd_msg message to write … … 395 424 LOGICAL, INTENT(IN), OPTIONAL :: ld_flush 396 425 !---------------------------------------------------------------- 397 IF( tm_logger%i_id /= 0 )THEN 398 IF( INDEX(TRIM(tm_logger%c_verb),'debug')/=0 )THEN 399 400 CALL logger__write("DEBUG :",cd_msg) 401 402 IF( PRESENT(ld_flush) )THEN 403 IF( ld_flush )THEN 404 CALL logger_flush() 405 ENDIF 406 ENDIF 407 ENDIF 408 ELSE 409 CALL logger_open('logger.log') 410 CALL logger_header() 411 CALL logger_fatal('you must have create logger to use logger_debug') 426 IF( tm_logger%l_use )THEN 427 IF( tm_logger%i_id /= 0 )THEN 428 IF( INDEX(TRIM(tm_logger%c_verb),'debug')/=0 )THEN 429 430 CALL logger__write("DEBUG :",cd_msg) 431 432 IF( PRESENT(ld_flush) )THEN 433 IF( ld_flush )THEN 434 CALL logger_flush() 435 ENDIF 436 ENDIF 437 ENDIF 438 ELSE 439 CALL logger_open('logger.log') 440 CALL logger_header() 441 CALL logger_fatal('you must have create logger to use logger_debug') 442 ENDIF 412 443 ENDIF 413 444 END SUBROUTINE logger_debug … … 418 449 !> 419 450 !> @author J.Paul 420 !> - November, 2013- Initial Version451 !> @date November, 2013 - Initial Version 421 452 ! 422 453 !> @param[in] cd_msg message to write … … 429 460 LOGICAL, INTENT(IN), OPTIONAL :: ld_flush 430 461 !---------------------------------------------------------------- 431 IF( tm_logger%i_id /= 0 )THEN 432 IF( INDEX(TRIM(tm_logger%c_verb),'info')/=0 )THEN 433 434 CALL logger__write("INFO :",cd_msg) 435 436 IF( PRESENT(ld_flush) )THEN 437 IF( ld_flush )THEN 438 CALL logger_flush() 439 ENDIF 440 ENDIF 441 ENDIF 442 ELSE 443 CALL logger_open('logger.log') 444 CALL logger_header() 445 CALL logger_fatal('you must have create logger to use logger_info') 462 IF( tm_logger%l_use )THEN 463 IF( tm_logger%i_id /= 0 )THEN 464 IF( INDEX(TRIM(tm_logger%c_verb),'info')/=0 )THEN 465 466 CALL logger__write("INFO :",cd_msg) 467 468 IF( PRESENT(ld_flush) )THEN 469 IF( ld_flush )THEN 470 CALL logger_flush() 471 ENDIF 472 ENDIF 473 ENDIF 474 ELSE 475 CALL logger_open('logger.log') 476 CALL logger_header() 477 CALL logger_fatal('you must have create logger to use logger_info') 478 ENDIF 446 479 ENDIF 447 480 END SUBROUTINE logger_info … … 452 485 !> 453 486 !> @author J.Paul 454 !> - November, 2013- Initial Version487 !> @date November, 2013 - Initial Version 455 488 ! 456 489 !> @param[in] cd_msg message to write … … 463 496 LOGICAL, INTENT(IN), OPTIONAL :: ld_flush 464 497 !---------------------------------------------------------------- 465 IF( tm_logger%i_id /= 0 )THEN 466 IF( INDEX(TRIM(tm_logger%c_verb),'warn')/=0 )THEN 467 468 CALL logger__write("WARNING :",cd_msg) 469 470 IF( PRESENT(ld_flush) )THEN 471 IF( ld_flush )THEN 472 CALL logger_flush() 473 ENDIF 474 ENDIF 475 ENDIF 476 ELSE 477 CALL logger_open('logger.log') 478 CALL logger_header() 479 CALL logger_fatal('you must have create logger to use logger_warn') 498 IF( tm_logger%l_use )THEN 499 IF( tm_logger%i_id /= 0 )THEN 500 IF( INDEX(TRIM(tm_logger%c_verb),'warn')/=0 )THEN 501 502 CALL logger__write("WARNING :",cd_msg) 503 504 IF( PRESENT(ld_flush) )THEN 505 IF( ld_flush )THEN 506 CALL logger_flush() 507 ENDIF 508 ENDIF 509 ENDIF 510 ELSE 511 CALL logger_open('logger.log') 512 CALL logger_header() 513 CALL logger_fatal('you must have create logger to use logger_warn') 514 ENDIF 480 515 ENDIF 481 516 END SUBROUTINE logger_warn … … 486 521 !> 487 522 !> @author J.Paul 488 !> - November, 2013- Initial Version523 !> @date November, 2013 - Initial Version 489 524 ! 490 525 !> @param[in] cd_msg message to write … … 500 535 CHARACTER(LEN=lc) :: cl_nerror 501 536 !---------------------------------------------------------------- 502 IF( tm_logger%i_id /= 0 )THEN 503 ! increment the error number 504 tm_logger%i_nerror=tm_logger%i_nerror+1 505 506 IF( INDEX(TRIM(tm_logger%c_verb),'error')/=0 )THEN 507 508 CALL logger__write("ERROR :",cd_msg) 509 510 IF( PRESENT(ld_flush) )THEN 511 IF( ld_flush )THEN 512 CALL logger_flush() 513 ENDIF 514 ENDIF 515 ENDIF 516 517 IF( tm_logger%i_nerror >= tm_logger%i_maxerror )THEN 518 WRITE(cl_nerror,*) tm_logger%i_maxerror 519 CALL logger_fatal(& 520 & 'Error count reached limit of '//TRIM(ADJUSTL(cl_nerror)) ) 521 ENDIF 522 ELSE 523 CALL logger_open('logger.log') 524 CALL logger_header() 525 CALL logger_fatal('you must have create logger to use logger_error') 526 ENDIF 527 537 IF( tm_logger%l_use )THEN 538 IF( tm_logger%i_id /= 0 )THEN 539 IF( TRIM(tm_logger%c_verb) /= 'none' )THEN 540 ! increment the error number 541 tm_logger%i_nerror=tm_logger%i_nerror+1 542 ENDIF 543 544 IF( INDEX(TRIM(tm_logger%c_verb),'error')/=0 )THEN 545 546 CALL logger__write("ERROR :",cd_msg) 547 548 IF( PRESENT(ld_flush) )THEN 549 IF( ld_flush )THEN 550 CALL logger_flush() 551 ENDIF 552 ENDIF 553 ENDIF 554 555 IF( tm_logger%i_nerror >= tm_logger%i_maxerror )THEN 556 WRITE(cl_nerror,*) tm_logger%i_maxerror 557 CALL logger_fatal(& 558 & 'Error count reached limit of '//TRIM(ADJUSTL(cl_nerror)) ) 559 ENDIF 560 ELSE 561 CALL logger_open('logger.log') 562 CALL logger_header() 563 CALL logger_fatal('you must have create logger to use logger_error') 564 ENDIF 565 ENDIF 528 566 END SUBROUTINE logger_error 529 567 !------------------------------------------------------------------- … … 532 570 !> 533 571 !> @author J.Paul 534 !> - November, 2013- Initial Version572 !> @date November, 2013 - Initial Version 535 573 ! 536 574 !> @param[in] cd_msg message to write … … 541 579 CHARACTER(LEN=*), INTENT(IN) :: cd_msg 542 580 !---------------------------------------------------------------- 543 IF( tm_logger%i_id /= 0 )THEN 544 IF( INDEX(TRIM(tm_logger%c_verb),'fatal')/=0 )THEN 545 ! increment the error number 546 tm_logger%i_nfatal=tm_logger%i_nfatal+1 547 548 CALL logger__write("FATAL :",cd_msg) 549 550 CALL logger_footer() 551 CALL logger_close() 552 553 WRITE(*,*) 'FATAL ERROR' 554 STOP 555 ENDIF 556 ELSE 557 CALL logger_open('logger.log') 558 CALL logger_header() 559 CALL logger_fatal('you must have create logger to use logger_fatal') 581 IF( tm_logger%l_use )THEN 582 IF( tm_logger%i_id /= 0 )THEN 583 IF( INDEX(TRIM(tm_logger%c_verb),'fatal')/=0 )THEN 584 ! increment the error number 585 tm_logger%i_nfatal=tm_logger%i_nfatal+1 586 587 CALL logger__write("FATAL :",cd_msg) 588 589 CALL logger_footer() 590 CALL logger_close() 591 592 WRITE(*,*) 'FATAL ERROR' 593 STOP 594 ENDIF 595 ELSE 596 CALL logger_open('logger.log') 597 CALL logger_header() 598 CALL logger_fatal('you must have create logger to use logger_fatal') 599 ENDIF 560 600 ENDIF 561 601 END SUBROUTINE logger_fatal … … 565 605 !> 566 606 !> @author J.Paul 567 !> - November, 2013- Initial Version607 !> @date November, 2013 - Initial Version 568 608 ! 569 609 !> @param[in] cd_verb verbosity of the message to write … … 615 655 616 656 END SUBROUTINE logger__write 657 !------------------------------------------------------------------- 658 !> @brief This function check validity of verbosity. 659 !> 660 !> @author J.Paul 661 !> @date February, 2015 - Initial Version 662 ! 663 !> @param[in] cd_verb verbosity of the message to write 664 !> @return verbosity is valid or not 665 !------------------------------------------------------------------- 666 FUNCTION logger__check_verb(cd_verb) 667 IMPLICIT NONE 668 ! Argument 669 CHARACTER(LEN=*), INTENT(IN) :: cd_verb 670 671 !function 672 LOGICAL :: logger__check_verb 673 674 ! local variable 675 ! loop indices 676 INTEGER(i4) :: ji 677 678 !---------------------------------------------------------------- 679 logger__check_verb=.FALSE. 680 681 DO ji=1,im_nverbosity 682 IF( TRIM(cd_verb) == TRIM(cm_verbosity(ji)) )THEN 683 logger__check_verb=.TRUE. 684 EXIT 685 ENDIF 686 ENDDO 687 688 IF( .NOT. logger__check_verb )THEN 689 CALL logger_open('logger.log') 690 CALL logger_header() 691 CALL logger_fatal('LOGGER : invalid verbosity, check namelist.'//& 692 & ' default one will be used.') 693 CALL logger_footer() 694 ENDIF 695 END FUNCTION logger__check_verb 617 696 END MODULE logger 618 697 -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/merge_bathy.f90
r5037 r6487 28 28 !> @endcode 29 29 !> 30 !> @note 31 !> you could find a template of the namelist in templates directory. 32 !> 30 33 !> merge_bathy.nam comprise 8 namelists: 31 34 !> - logger namelist (namlog) … … 45 48 !> - cn_logfile : logger filename 46 49 !> - cn_verbosity : verbosity ('trace','debug','info', 47 !> 'warning','error','fatal' )50 !> 'warning','error','fatal','none') 48 51 !> - in_maxerror : maximum number of error allowed 49 52 !> … … 62 65 !> * _variable namelist (namvar)_: 63 66 !> - cn_varinfo : list of variable and extra information about request(s) 64 !> to be used .<br/>67 !> to be used (separated by ',').<br/> 65 68 !> each elements of *cn_varinfo* is a string character.<br/> 66 69 !> it is composed of the variable name follow by ':', 67 70 !> then request(s) to be used on this variable.<br/> 68 71 !> request could be: 69 !> - int erpolation method72 !> - int = interpolation method 70 73 !> 71 74 !> requests must be separated by ';'.<br/> … … 74 77 !> informations about available method could be find in 75 78 !> @ref interp modules.<br/> 76 !> Example: 'bathymetry: cubic'79 !> Example: 'bathymetry: int=cubic' 77 80 !> @note 78 81 !> If you do not specify a method which is required, … … 95 98 !> segments are separated by '|'.<br/> 96 99 !> each segments of the boundary is composed of: 97 !> - orthogonal indice (.ie. for north boundary,98 !> J-indice where boundary are).99 !> - first indice of boundary(I-indice for north boundary)100 !> - last indice of boundary(I-indice for north boundary)<br/>101 !> indices must be separated by ' ,' .<br/>100 !> - indice of velocity (orthogonal to boundary .ie. 101 !> for north boundary, J-indice). 102 !> - indice of segment start (I-indice for north boundary) 103 !> - indice of segment end (I-indice for north boundary)<br/> 104 !> indices must be separated by ':' .<br/> 102 105 !> - optionally, boundary size could be added between '(' and ')' 103 106 !> in the first segment defined. … … 106 109 !> 107 110 !> Examples: 108 !> - cn_north='index1,first1,last1(width)' 109 !> - cn_north='index1(width),first1,last1|index2,first2,last2' 111 !> - cn_north='index1,first1:last1(width)' 112 !> - cn_north='index1(width),first1:last1|index2,first2:last2' 113 !> 110 114 !> - cn_south : south boundary indices on fine grid<br/> 111 115 !> - cn_east : east boundary indices on fine grid<br/> … … 121 125 !> @date Sepember, 2014 122 126 !> - add header for user 127 !> @date July, 2015 128 !> - extrapolate all land points 129 !> - add attributes with boundary string character (as in namelist) 123 130 !> 124 131 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 153 160 CHARACTER(LEN=lc) :: cl_namelist 154 161 CHARACTER(LEN=lc) :: cl_date 162 CHARACTER(LEN=lc) :: cl_tmp 155 163 156 164 INTEGER(i4) :: il_narg … … 162 170 INTEGER(i4) :: il_jmin0 163 171 INTEGER(i4) :: il_jmax0 172 INTEGER(i4) :: il_shift 164 173 INTEGER(i4) , DIMENSION(ip_maxdim) :: il_rho 165 174 INTEGER(i4) , DIMENSION(2,2) :: il_ind … … 231 240 NAMELIST /namlog/ & !< logger namelist 232 241 & cn_logfile, & !< log file 233 & cn_verbosity !< log verbosity 242 & cn_verbosity, & !< log verbosity 243 & in_maxerror !< logger maximum error 234 244 235 245 NAMELIST /namcfg/ & !< config namelist … … 298 308 READ( il_fileid, NML = namlog ) 299 309 ! define log file 300 CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity), 310 CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity),in_maxerror) 301 311 CALL logger_header() 302 312 … … 510 520 ENDIF 511 521 522 523 IF( tl_bdy(jp_north)%l_use )THEN 524 ! add shift on north boundary 525 ! boundary compute on T point but express on U or V point 526 il_shift=1 527 528 cl_tmp=TRIM(fct_str(tl_bdy(jp_north)%t_seg(1)%i_index-il_shift))//','//& 529 & TRIM(fct_str(tl_bdy(jp_north)%t_seg(1)%i_first))//':'//& 530 & TRIM(fct_str(tl_bdy(jp_north)%t_seg(1)%i_last))//& 531 & '('//TRIM(fct_str(tl_bdy(jp_north)%t_seg(1)%i_width))//')' 532 DO ji=2,tl_bdy(jp_north)%i_nseg 533 cl_tmp=TRIM(cl_tmp)//'|'//& 534 & TRIM(fct_str(tl_bdy(jp_north)%t_seg(ji)%i_index-il_shift))//','//& 535 & TRIM(fct_str(tl_bdy(jp_north)%t_seg(ji)%i_first))//':'//& 536 & TRIM(fct_str(tl_bdy(jp_north)%t_seg(ji)%i_last)) 537 ENDDO 538 tl_att=att_init("bdy_north",TRIM(cl_tmp)) 539 CALL file_add_att(tl_fileout, tl_att) 540 ENDIF 541 542 IF( tl_bdy(jp_south)%l_use )THEN 543 544 cl_tmp=TRIM(fct_str(tl_bdy(jp_south)%t_seg(1)%i_index))//','//& 545 & TRIM(fct_str(tl_bdy(jp_south)%t_seg(1)%i_first))//':'//& 546 & TRIM(fct_str(tl_bdy(jp_south)%t_seg(1)%i_last))//& 547 & '('//TRIM(fct_str(tl_bdy(jp_south)%t_seg(1)%i_width))//')' 548 DO ji=2,tl_bdy(jp_south)%i_nseg 549 cl_tmp=TRIM(cl_tmp)//'|'//& 550 & TRIM(fct_str(tl_bdy(jp_south)%t_seg(ji)%i_index))//','//& 551 & TRIM(fct_str(tl_bdy(jp_south)%t_seg(ji)%i_first))//':'//& 552 & TRIM(fct_str(tl_bdy(jp_south)%t_seg(ji)%i_last)) 553 ENDDO 554 555 tl_att=att_init("bdy_south",TRIM(cl_tmp)) 556 CALL file_add_att(tl_fileout, tl_att) 557 ENDIF 558 559 IF( tl_bdy(jp_east)%l_use )THEN 560 ! add shift on east boundary 561 ! boundary compute on T point but express on U or V point 562 il_shift=1 563 564 cl_tmp=TRIM(fct_str(tl_bdy(jp_east)%t_seg(1)%i_index-il_shift))//','//& 565 & TRIM(fct_str(tl_bdy(jp_east)%t_seg(1)%i_first))//':'//& 566 & TRIM(fct_str(tl_bdy(jp_east)%t_seg(1)%i_last))//& 567 & '('//TRIM(fct_str(tl_bdy(jp_east)%t_seg(1)%i_width))//')' 568 DO ji=2,tl_bdy(jp_east)%i_nseg 569 cl_tmp=TRIM(cl_tmp)//'|'//& 570 & TRIM(fct_str(tl_bdy(jp_east)%t_seg(ji)%i_index-il_shift))//','//& 571 & TRIM(fct_str(tl_bdy(jp_east)%t_seg(ji)%i_first))//':'//& 572 & TRIM(fct_str(tl_bdy(jp_east)%t_seg(ji)%i_last)) 573 ENDDO 574 575 tl_att=att_init("bdy_east",TRIM(cl_tmp)) 576 CALL file_add_att(tl_fileout, tl_att) 577 ENDIF 578 579 IF( tl_bdy(jp_west)%l_use )THEN 580 581 cl_tmp=TRIM(fct_str(tl_bdy(jp_west)%t_seg(1)%i_index))//','//& 582 & TRIM(fct_str(tl_bdy(jp_west)%t_seg(1)%i_first))//':'//& 583 & TRIM(fct_str(tl_bdy(jp_west)%t_seg(1)%i_last))//& 584 & '('//TRIM(fct_str(tl_bdy(jp_west)%t_seg(1)%i_width))//')' 585 DO ji=2,tl_bdy(jp_west)%i_nseg 586 cl_tmp=TRIM(cl_tmp)//'|'//& 587 & TRIM(fct_str(tl_bdy(jp_west)%t_seg(ji)%i_index))//','//& 588 & TRIM(fct_str(tl_bdy(jp_west)%t_seg(ji)%i_first))//':'//& 589 & TRIM(fct_str(tl_bdy(jp_west)%t_seg(ji)%i_last)) 590 ENDDO 591 592 tl_att=att_init("bdy_west",TRIM(cl_tmp)) 593 CALL file_add_att(tl_fileout, tl_att) 594 ENDIF 595 512 596 ! create file 513 597 CALL iom_create(tl_fileout) … … 525 609 CALL mpp_clean(tl_bathy0) 526 610 DEALLOCATE(dl_weight) 611 CALL boundary_clean(tl_bdy(:)) 527 612 528 613 ! close log file … … 908 993 909 994 ! extrapolate variable 910 CALL extrap_fill_value( td_var, id_offset=id_offset(:,:), & 911 & id_rho=id_rho(:), & 912 & id_iext=il_iext, id_jext=il_jext ) 995 CALL extrap_fill_value( td_var ) 913 996 914 997 ! interpolate Bathymetry -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/mpp.f90
r5037 r6487 165 165 !> to get processors to be used:<br/> 166 166 !> @code 167 !> CALL mpp_get_use( td_mpp, id_imin, id_imax, id_idim,&168 !> & id_jmin, id_jmax , id_jdim)167 !> CALL mpp_get_use( td_mpp, id_imin, id_imax, & 168 !> & id_jmin, id_jmax ) 169 169 !> @endcode 170 170 !> - id_imin 171 171 !> - id_imax 172 !> - id_idim173 172 !> - id_jmin 174 173 !> - id_jmax 175 !> - id_jdim176 174 !> 177 175 !> to get sub domains which form global domain contour:<br/> … … 352 350 !> 353 351 !> @author J.Paul 354 !> - November, 2013- Initial Version352 !> @date November, 2013 - Initial Version 355 353 !> @date November, 2014 356 354 !> - use function instead of overload assignment operator … … 379 377 ! copy mpp variable 380 378 mpp__copy_unit%c_name = TRIM(td_mpp%c_name) 379 mpp__copy_unit%i_id = td_mpp%i_id 381 380 mpp__copy_unit%i_niproc = td_mpp%i_niproc 382 381 mpp__copy_unit%i_njproc = td_mpp%i_njproc … … 425 424 !> 426 425 !> @author J.Paul 427 !> - November, 2013- Initial Version426 !> @date November, 2013 - Initial Version 428 427 !> @date November, 2014 429 428 !> - use function instead of overload assignment operator … … 454 453 ! 455 454 !> @author J.Paul 456 !> - Nov, 2013- Initial Version455 !> @date November, 2013 - Initial Version 457 456 ! 458 457 !> @param[in] td_mpp mpp structure … … 495 494 ! print dimension 496 495 IF( td_mpp%i_ndim /= 0 )THEN 497 WRITE(*,'(/a)') " Filedimension"496 WRITE(*,'(/a)') " MPP dimension" 498 497 DO ji=1,ip_maxdim 499 498 IF( td_mpp%t_dim(ji)%l_use )THEN … … 698 697 CALL dim_clean(tl_dim) 699 698 700 IF( ( PRESENT(id_niproc) .AND. (.NOT. PRESENT(id_n iproc))) .OR. &699 IF( ( PRESENT(id_niproc) .AND. (.NOT. PRESENT(id_njproc))) .OR. & 701 700 ((.NOT. PRESENT(id_niproc)) .AND. PRESENT(id_njproc) ) )THEN 702 701 CALL logger_warn( "MPP INIT: number of processors following I and J "//& … … 912 911 !> 913 912 !> @author J.Paul 914 !> - November, 2013- Initial Version913 !> @date November, 2013 - Initial Version 915 914 ! 916 915 !> @param[in] td_file file strcuture … … 1028 1027 ! create some attributes for domain decomposition (use with dimg file) 1029 1028 tl_att=att_init( "DOMAIN_number_total", mpp__init_file%i_nproc ) 1030 CALL mpp_ add_att(mpp__init_file, tl_att)1029 CALL mpp_move_att(mpp__init_file, tl_att) 1031 1030 1032 1031 tl_att=att_init( "DOMAIN_I_position_first", mpp__init_file%t_proc(:)%i_impp ) 1033 CALL mpp_ add_att(mpp__init_file, tl_att)1032 CALL mpp_move_att(mpp__init_file, tl_att) 1034 1033 1035 1034 tl_att=att_init( "DOMAIN_J_position_first", mpp__init_file%t_proc(:)%i_jmpp ) 1036 CALL mpp_ add_att(mpp__init_file, tl_att)1035 CALL mpp_move_att(mpp__init_file, tl_att) 1037 1036 1038 1037 tl_att=att_init( "DOMAIN_I_position_last", mpp__init_file%t_proc(:)%i_lci ) 1039 CALL mpp_ add_att(mpp__init_file, tl_att)1038 CALL mpp_move_att(mpp__init_file, tl_att) 1040 1039 1041 1040 tl_att=att_init( "DOMAIN_J_position_last", mpp__init_file%t_proc(:)%i_lcj ) 1042 CALL mpp_ add_att(mpp__init_file, tl_att)1041 CALL mpp_move_att(mpp__init_file, tl_att) 1043 1042 1044 1043 tl_att=att_init( "DOMAIN_I_halo_size_start", mpp__init_file%t_proc(:)%i_ldi ) 1045 CALL mpp_ add_att(mpp__init_file, tl_att)1044 CALL mpp_move_att(mpp__init_file, tl_att) 1046 1045 1047 1046 tl_att=att_init( "DOMAIN_J_halo_size_start", mpp__init_file%t_proc(:)%i_ldj ) 1048 CALL mpp_ add_att(mpp__init_file, tl_att)1047 CALL mpp_move_att(mpp__init_file, tl_att) 1049 1048 1050 1049 tl_att=att_init( "DOMAIN_I_halo_size_end", mpp__init_file%t_proc(:)%i_lei ) 1051 CALL mpp_ add_att(mpp__init_file, tl_att)1050 CALL mpp_move_att(mpp__init_file, tl_att) 1052 1051 1053 1052 tl_att=att_init( "DOMAIN_J_halo_size_end", mpp__init_file%t_proc(:)%i_lej ) 1054 CALL mpp_ add_att(mpp__init_file, tl_att)1053 CALL mpp_move_att(mpp__init_file, tl_att) 1055 1054 1056 1055 ! clean … … 1122 1121 CALL file_clean(tl_file) 1123 1122 1124 CALL logger_debug("MPP INIT READ: fin init_read ")1125 1123 END FUNCTION mpp__init_file 1126 1124 !------------------------------------------------------------------- … … 1131 1129 ! 1132 1130 !> @author J.Paul 1133 !> - November, 2013- Initial Version 1131 !> @date November, 2013 - Initial Version 1132 !> @date July, 2015 - add only use dimension in MPP structure 1134 1133 !> 1135 1134 !> @param[in] td_file file strcuture … … 1163 1162 IF( td_file%i_id == 0 )THEN 1164 1163 CALL logger_info(" id "//TRIM(fct_str(td_file%i_id))) 1165 CALL logger_error("MPP INIT READ: netcdf file "// TRIM(td_file%c_name)//&1166 &" not opened")1164 CALL logger_error("MPP INIT READ: netcdf file "//& 1165 & TRIM(td_file%c_name)//" not opened") 1167 1166 ELSE 1168 1167 … … 1191 1190 CALL mpp_add_dim(mpp__init_file_cdf,tl_dim) 1192 1191 ENDIF 1193 tl_dim=dim_init( td_file%t_dim(3)%c_name, td_file%t_dim(3)%i_len) 1194 CALL mpp_add_dim(mpp__init_file_cdf,tl_dim) 1195 1196 tl_dim=dim_init( td_file%t_dim(4)%c_name, td_file%t_dim(4)%i_len) 1197 CALL mpp_add_dim(mpp__init_file_cdf,tl_dim) 1192 1193 IF( td_file%t_dim(3)%l_use )THEN 1194 tl_dim=dim_init( td_file%t_dim(3)%c_name, td_file%t_dim(3)%i_len) 1195 CALL mpp_add_dim(mpp__init_file_cdf,tl_dim) 1196 ENDIF 1197 1198 IF( td_file%t_dim(4)%l_use )THEN 1199 tl_dim=dim_init( td_file%t_dim(4)%c_name, td_file%t_dim(4)%i_len) 1200 CALL mpp_add_dim(mpp__init_file_cdf,tl_dim) 1201 ENDIF 1198 1202 1199 1203 ! initialise file/processor … … 1312 1316 ! 1313 1317 !> @author J.Paul 1314 !> - November, 2013- Initial Version1318 !> @date November, 2013 - Initial Version 1315 1319 ! 1316 1320 !> @param[in] td_file file strcuture … … 1532 1536 ! 1533 1537 !> @author J.Paul 1534 !> - Nov, 2013- Initial Version1538 !> @date November, 2013 - Initial Version 1535 1539 ! 1536 1540 !> @param[in] td_mpp mpp structure … … 1624 1628 IF( il_varid /= 0 )THEN 1625 1629 1626 CALL logger_error( " MPP ADD VAR: variable "//TRIM(td_var%c_name)//&1627 & ", standard name "//TRIM(td_var%c_stdname)//&1628 & ", already in mpp "//TRIM(td_mpp%c_name) )1629 1630 1630 DO ji=1,td_mpp%t_proc(1)%i_nvar 1631 1631 CALL logger_debug( " MPP ADD VAR: in mpp structure : & … … 1634 1634 & TRIM(td_mpp%t_proc(1)%t_var(ji)%c_stdname) ) 1635 1635 ENDDO 1636 CALL logger_error( " MPP ADD VAR: variable "//TRIM(td_var%c_name)//& 1637 & ", standard name "//TRIM(td_var%c_stdname)//& 1638 & ", already in mpp "//TRIM(td_mpp%c_name) ) 1636 1639 1637 1640 ELSE … … 1675 1678 ! 1676 1679 !> @author J.Paul 1677 !> - November, 2013- Initial Version1680 !> @date November, 2013 - Initial Version 1678 1681 ! 1679 1682 !> @param[in] td_mpp mpp structure … … 1840 1843 !> @author J.Paul 1841 1844 !> @date November, 2013 - Initial version 1845 !> @date February, 2015 1846 !> - define local variable structure to avoid mistake with pointer 1842 1847 ! 1843 1848 !> @param[inout] td_mpp mpp strcuture … … 1852 1857 ! local variable 1853 1858 INTEGER(i4) :: il_varid 1859 TYPE(TVAR) :: tl_var 1854 1860 !---------------------------------------------------------------- 1855 1861 ! check if mpp exist … … 1882 1888 ELSE 1883 1889 1884 CALL mpp_del_var(td_mpp, td_mpp%t_proc(1)%t_var(il_varid)) 1890 tl_var=var_copy(td_mpp%t_proc(1)%t_var(il_varid)) 1891 CALL mpp_del_var(td_mpp, tl_var) 1885 1892 1886 1893 ENDIF … … 2193 2200 !> 2194 2201 !> @author J.Paul 2195 !> - November, 2013- Initial Version 2202 !> @date November, 2013 - Initial Version 2203 !> @date July, 2015 2204 !> - rewrite the same as way var_add_dim 2196 2205 !> 2197 2206 !> @param[inout] td_mpp mpp structure … … 2208 2217 2209 2218 ! loop indices 2210 INTEGER(i4) :: ji2211 2219 !---------------------------------------------------------------- 2212 2220 IF( td_mpp%i_ndim <= ip_maxdim )THEN 2213 2221 2214 ! check if dimension already in mpp structure 2215 il_ind=dim_get_index(td_mpp%t_dim(:), td_dim%c_name, td_dim%c_sname) 2216 IF( il_ind /= 0 )THEN 2217 2218 IF( td_mpp%t_dim(il_ind)%l_use )THEN 2219 CALL logger_error( & 2220 & "MPP ADD DIM: dimension "//TRIM(td_dim%c_name)//& 2221 & ", short name "//TRIM(td_dim%c_sname)//& 2222 & ", already used in mpp "//TRIM(td_mpp%c_name) ) 2223 ELSE 2224 ! replace dimension 2225 td_mpp%t_dim(il_ind)=dim_copy(td_dim) 2226 td_mpp%t_dim(il_ind)%i_id=il_ind 2227 td_mpp%t_dim(il_ind)%l_use=.TRUE. 2228 ENDIF 2229 2222 ! check if dimension already used in mpp structure 2223 il_ind=SCAN(TRIM(cp_dimorder),TRIM(td_dim%c_sname)) 2224 IF( il_ind == 0 )THEN 2225 CALL logger_warn( & 2226 & " MPP ADD DIM: dimension "//TRIM(td_dim%c_name)//& 2227 & ", short name "//TRIM(td_dim%c_sname)//& 2228 & ", will not be added in mpp "//TRIM(td_mpp%c_name) ) 2229 ELSEIF( td_mpp%t_dim(il_ind)%l_use )THEN 2230 CALL logger_error( & 2231 & " MPP ADD DIM: dimension "//TRIM(td_dim%c_name)//& 2232 & ", short name "//TRIM(td_dim%c_sname)//& 2233 & ", already used in mpp "//TRIM(td_mpp%c_name) ) 2230 2234 ELSE 2231 2235 2232 IF( td_mpp%i_ndim == ip_maxdim )THEN 2233 CALL logger_error( & 2234 & "MPP ADD DIM: can not add dimension "//TRIM(td_dim%c_name)//& 2235 & ", short name "//TRIM(td_dim%c_sname)//& 2236 & ", in mpp "//TRIM(td_mpp%c_name)//". Already "//& 2237 & TRIM(fct_str(ip_maxdim))//" dimensions." ) 2238 ELSE 2239 ! search empty dimension 2240 DO ji=1,ip_maxdim 2241 IF( td_mpp%t_dim(ji)%i_id == 0 )THEN 2242 il_ind=ji 2243 EXIT 2244 ENDIF 2245 ENDDO 2246 2247 ! add new dimension 2248 td_mpp%t_dim(il_ind)=dim_copy(td_dim) 2249 ! update number of attribute 2250 td_mpp%i_ndim=COUNT(td_mpp%t_dim(:)%l_use) 2251 2252 td_mpp%t_dim(il_ind)%l_use=.TRUE. 2253 td_mpp%t_dim(il_ind)%i_id=td_mpp%i_ndim 2254 ENDIF 2236 ! back to disorder dimension array 2237 CALL dim_disorder(td_mpp%t_dim(:)) 2238 2239 ! add new dimension 2240 td_mpp%t_dim(td_mpp%i_ndim+1)=dim_copy(td_dim) 2241 2242 ! update number of attribute 2243 td_mpp%i_ndim=COUNT(td_mpp%t_dim(:)%l_use) 2255 2244 2256 2245 ENDIF 2246 ! reorder dimension to ('x','y','z','t') 2247 CALL dim_reorder(td_mpp%t_dim(:)) 2257 2248 2258 2249 ELSE … … 2268 2259 !> 2269 2260 !> @author J.Paul 2270 !> - November, 2013- Initial Version 2261 !> @date November, 2013 - Initial Version 2262 !> @date July, 2015 2263 !> - rewrite the same as way var_del_dim 2271 2264 !> 2272 2265 !> @param[inout] td_mpp mpp structure … … 2280 2273 2281 2274 ! local variable 2282 INTEGER(i4) :: il_status2283 2275 INTEGER(i4) :: il_ind 2284 TYPE(TDIM) , DIMENSION(:), ALLOCATABLE:: tl_dim2276 TYPE(TDIM) :: tl_dim 2285 2277 2286 2278 ! loop indices 2287 INTEGER(i4) :: ji 2288 !---------------------------------------------------------------- 2289 ! check if dimension already in mpp structure 2290 il_ind=dim_get_index(td_mpp%t_dim(:), td_dim%c_name, td_dim%c_sname) 2291 IF( il_ind == 0 )THEN 2292 2293 CALL logger_error( & 2294 & "MPP DEL DIM: no dimension "//TRIM(td_dim%c_name)//& 2279 !---------------------------------------------------------------- 2280 2281 2282 IF( td_mpp%i_ndim <= ip_maxdim )THEN 2283 2284 CALL logger_trace( & 2285 & " MPP DEL DIM: delete dimension "//TRIM(td_dim%c_name)//& 2295 2286 & ", short name "//TRIM(td_dim%c_sname)//& 2296 2287 & ", in mpp "//TRIM(td_mpp%c_name) ) 2288 2289 ! check if dimension already in variable structure 2290 il_ind=SCAN(TRIM(cp_dimorder),TRIM(td_dim%c_sname)) 2291 2292 ! replace dimension by empty one 2293 td_mpp%t_dim(il_ind)=dim_copy(tl_dim) 2294 2295 ! update number of dimension 2296 td_mpp%i_ndim=COUNT(td_mpp%t_dim(:)%l_use) 2297 2298 ! reorder dimension to ('x','y','z','t') 2299 CALL dim_reorder(td_mpp%t_dim) 2297 2300 2298 2301 ELSE 2299 2300 ALLOCATE( tl_dim(td_mpp%i_ndim-1), stat=il_status ) 2301 IF(il_status /= 0 )THEN 2302 2303 CALL logger_error( & 2304 & "MPP DEL DIM: not enough space to put dimensions from "//& 2305 & TRIM(td_mpp%c_name)//" in temporary dimension structure") 2306 2307 ELSE 2308 2309 ! save temporary dimension's mpp structure 2310 tl_dim( 1 : il_ind-1 ) = dim_copy(td_mpp%t_dim( 1 : il_ind-1 )) 2311 tl_dim( il_ind : td_mpp%i_ndim-1 ) = & 2312 & dim_copy(td_mpp%t_dim( il_ind+1 : td_mpp%i_ndim )) 2313 2314 ! remove dimension from file 2315 CALL dim_clean(td_mpp%t_dim(:)) 2316 ! copy dimension in file, except one 2317 td_mpp%t_dim(1:td_mpp%i_ndim)=dim_copy(tl_dim(:)) 2318 2319 ! update number of dimension 2320 td_mpp%i_ndim=td_mpp%i_ndim-1 2321 2322 ! update dimension id 2323 DO ji=1,td_mpp%i_ndim 2324 td_mpp%t_dim(ji)%i_id=ji 2325 ENDDO 2326 2327 ! clean 2328 CALL dim_clean(tl_dim(:)) 2329 DEALLOCATE(tl_dim) 2330 2331 ENDIF 2332 2302 CALL logger_error( & 2303 & " MPP DEL DIM: too much dimension in mpp "//& 2304 & TRIM(td_mpp%c_name)//" ("//TRIM(fct_str(td_mpp%i_ndim))//")") 2333 2305 ENDIF 2334 2306 … … 2340 2312 !> 2341 2313 !> @author J.Paul 2342 !> - November, 2013- Initial Version2314 !> @date November, 2013 - Initial Version 2343 2315 !> 2344 2316 !> @param[inout] td_mpp mpp structure … … 2488 2460 & ", in mpp structure "//TRIM(td_mpp%c_name) ) 2489 2461 2490 IF( ASSOCIATED(td_mpp%t_proc(1)%t_ var) )THEN2462 IF( ASSOCIATED(td_mpp%t_proc(1)%t_att) )THEN 2491 2463 DO ji=1,td_mpp%t_proc(1)%i_natt 2492 2464 CALL logger_debug( "MPP DEL ATT: in mpp structure : & 2493 & attribute : "//TRIM(td_mpp%t_proc(1)%t_ var(ji)%c_name) )2465 & attribute : "//TRIM(td_mpp%t_proc(1)%t_att(ji)%c_name) ) 2494 2466 ENDDO 2495 2467 ENDIF … … 2516 2488 !> @author J.Paul 2517 2489 !> @date November, 2013 - Initial version 2490 !> @date February, 2015 2491 !> - define local attribute structure to avoid mistake with pointer 2518 2492 ! 2519 2493 !> @param[inout] td_mpp mpp strcuture … … 2527 2501 2528 2502 ! local variable 2529 INTEGER(i4) :: il_attid 2503 INTEGER(i4) :: il_attid 2504 TYPE(TATT) :: tl_att 2530 2505 !---------------------------------------------------------------- 2531 2506 ! check if mpp exist … … 2551 2526 IF( il_attid == 0 )THEN 2552 2527 2553 CALL logger_ warn( &2528 CALL logger_debug( & 2554 2529 & "MPP DEL ATT : there is no attribute with "//& 2555 2530 & "name "//TRIM(cd_name)//" in mpp structure "//& … … 2558 2533 ELSE 2559 2534 2560 CALL mpp_del_att(td_mpp, td_mpp%t_proc(1)%t_att(il_attid)) 2535 tl_att=att_copy(td_mpp%t_proc(1)%t_att(il_attid)) 2536 CALL mpp_del_att(td_mpp, tl_att) 2561 2537 2562 2538 ENDIF … … 2863 2839 2864 2840 CALL logger_info("MPP OPTIMIZ: number of processor "//& 2865 & TRIM(fct_str(tl_mpp%i_nproc)) ) 2841 & TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//& 2842 & TRIM(fct_str(tl_mpp%i_nproc)) ) 2866 2843 IF( tl_mpp%i_nproc > td_mpp%i_nproc .AND. & 2867 2844 & tl_mpp%i_nproc <= il_maxproc )THEN 2868 2845 ! save optimiz decomposition 2846 2847 CALL logger_info("MPP OPTIMIZ:save this decomposition "//& 2848 & TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//& 2849 & TRIM(fct_str(tl_mpp%i_nproc)) ) 2869 2850 2870 2851 ! clean mpp … … 3146 3127 !> 3147 3128 !> @author J.Paul 3148 !> @date November, 2013 3129 !> @date November, 2013 - Initial version 3149 3130 !> 3150 3131 !> @param[inout] td_mpp mpp strcuture … … 3184 3165 !> 3185 3166 !> @author J.Paul 3186 !> @date November, 2013 3167 !> @date November, 2013 - Initial version 3187 3168 !> 3188 3169 !> @param[in] td_mpp mpp strcuture … … 3249 3230 ! 3250 3231 !> @author J.Paul 3251 !> @date November, 2013 3232 !> @date November, 2013 - Initial version 3252 3233 ! 3253 3234 !> @param[in] td_mpp mpp strcuture … … 3311 3292 !> 3312 3293 !> @author J.Paul 3313 !> @date November, 2013 3294 !> @date November, 2013 - Initial version 3314 3295 !> 3315 3296 !> @param[inout] td_mpp mpp strcuture … … 3404 3385 !> 3405 3386 !> @author J.Paul 3406 !> - November, 2013- Initial Version3387 !> @date November, 2013 - Initial Version 3407 3388 !> 3408 3389 !> @param[in] td_mpp mpp structure … … 3417 3398 3418 3399 ! local variable 3419 INTEGER(i4) :: il_ndim3420 3400 3421 3401 ! loop indices … … 3429 3409 mpp__check_var_dim=.FALSE. 3430 3410 3431 CALL logger_error( &3432 & "MPP CHECK DIM: variable and mpp dimension differ"//&3433 & " for variable "//TRIM(td_var%c_name)//&3434 & " and mpp "//TRIM(td_mpp%c_name))3435 3436 3411 CALL logger_debug( & 3437 3412 & " mpp dimension: "//TRIM(fct_str(td_mpp%i_ndim))//& 3438 3413 & " variable dimension: "//TRIM(fct_str(td_var%i_ndim)) ) 3439 il_ndim=MIN(td_var%i_ndim, td_mpp%i_ndim ) 3440 DO ji = 1, il_ndim 3414 DO ji = 1, ip_maxdim 3441 3415 CALL logger_debug( & 3442 3416 & "MPP CHECK DIM: for dimension "//& … … 3448 3422 & ", variable used "//TRIM(fct_str(td_var%t_dim(ji)%l_use))) 3449 3423 ENDDO 3424 3425 CALL logger_error( & 3426 & "MPP CHECK DIM: variable and mpp dimension differ"//& 3427 & " for variable "//TRIM(td_var%c_name)//& 3428 & " and mpp "//TRIM(td_mpp%c_name)) 3429 3450 3430 ENDIF 3451 3431 … … 3456 3436 ! 3457 3437 !> @author J.Paul 3458 !> - November, 2013- Initial Version3438 !> @date November, 2013 - Initial Version 3459 3439 ! 3460 3440 !> @param[in] td_file array of file structure … … 3496 3476 ! 3497 3477 !> @author J.Paul 3498 !> - Ocotber, 2014- Initial Version3478 !> @date Ocotber, 2014 - Initial Version 3499 3479 ! 3500 3480 !> @param[in] td_mpp mpp file structure -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/multi.f90
r5037 r6487 61 61 !> @date October, 2014 62 62 !> - use mpp file structure instead of file 63 !> @date November, 2014 - Fix memory leaks bug 63 !> @date November, 2014 64 !> - Fix memory leaks bug 64 65 ! 65 66 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 118 119 !> 119 120 !> @author J.Paul 120 !> - November, 2013- Initial Version121 !> @date November, 2013 - Initial Version 121 122 !> @date November, 2014 122 123 !> - use function instead of overload assignment operator (to avoid memory leak) … … 169 170 !> 170 171 !> @author J.Paul 171 !> - November, 2013- Initial Version 172 !> @date November, 2013 - Initial Version 173 !> @date July, 2015 174 !> - check if variable to be read is in file 172 175 !> 173 176 !> @param[in] cd_varfile variable location information (from namelist) … … 190 193 191 194 INTEGER(i4) :: il_nvar 195 INTEGER(i4) :: il_varid 192 196 193 197 LOGICAL :: ll_dim … … 242 246 ! define variable 243 247 IF( TRIM(fct_lower(cl_lower)) /= 'all' )THEN 248 249 ! check if variable is in file 250 il_varid=var_get_index(tl_mpp%t_proc(1)%t_var(:),cl_lower) 251 IF( il_varid == 0 )THEN 252 CALL logger_fatal("MULTI INIT: variable "//& 253 & TRIM(cl_name)//" not in file "//& 254 & TRIM(cl_file) ) 255 ENDIF 244 256 245 257 ! clean var … … 317 329 ! 318 330 !> @author J.Paul 319 !> - November, 2013- Initial Version331 !> @date November, 2013 - Initial Version 320 332 ! 321 333 !> @param[in] td_multi multi file structure … … 348 360 ! 349 361 !> @author J.Paul 350 !> - November, 2013- Initial Version362 !> @date November, 2013 - Initial Version 351 363 ! 352 364 !> @param[in] td_multi multi file structure … … 391 403 ! 392 404 !> @author J.Paul 393 !> - November, 2013- Initial Version405 !> @date November, 2013 - Initial Version 394 406 !> @date October, 2014 395 407 !> - use mpp file structure instead of file -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/phycst.f90
r5037 r6487 25 25 PUBLIC :: dp_rearth !< earth radius (km) 26 26 PUBLIC :: dp_deg2rad !< degree to radian ratio 27 PUBLIC :: dp_rad2deg !< radian to degree ratio 27 28 PUBLIC :: dp_delta !< 28 29 … … 31 32 REAL(dp), PARAMETER :: dp_rearth = 6871._dp 32 33 REAL(dp), PARAMETER :: dp_deg2rad = dp_pi/180.0 34 REAL(dp), PARAMETER :: dp_rad2deg = 180.0/dp_pi 33 35 34 REAL(dp), PARAMETER :: dp_delta=1.e- 236 REAL(dp), PARAMETER :: dp_delta=1.e-6 35 37 END MODULE phycst 36 38 -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/variable.f90
r5037 r6487 281 281 !> @date November, 2014 282 282 !> - Fix memory leaks bug 283 !> @date June, 2015 284 !> - change way to get variable information in namelist 285 !> @date July, 2015 286 !> - add subroutine var_chg_unit to change unit of output variable 283 287 ! 284 288 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 293 297 USE att ! attribute manager 294 298 USE dim ! dimension manager 299 USE math ! mathematical function 295 300 IMPLICIT NONE 296 301 ! NOTE_avoid_public_variables_if_possible … … 318 323 PUBLIC :: var_concat !< concatenate two variables 319 324 PUBLIC :: var_limit_value !< forced min and max value 325 PUBLIC :: var_chg_unit !< change variable unit and value 320 326 PUBLIC :: var_max_dim !< get array of maximum dimension use 321 327 PUBLIC :: var_reorder !< reorder table of value in variable structure … … 382 388 PRIVATE :: var__get_max ! get maximum value from namelist 383 389 PRIVATE :: var__get_min ! get minimum value from namelist 390 PRIVATE :: var__get_unf ! get scale factor value from namelist 391 PRIVATE :: var__get_unt ! get unit from namelist 384 392 PRIVATE :: var__get_interp ! get interpolation method from namelist 385 393 PRIVATE :: var__get_extrap ! get extrapolation method from namelist … … 401 409 TYPE(TATT), DIMENSION(:), POINTER :: t_att => NULL() !< variable attributes 402 410 TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim !< variable dimension 403 411 404 412 LOGICAL :: l_file = .FALSE. !< variable read in a file 405 413 … … 414 422 REAL(dp) :: d_min = dp_fill !< minimum value 415 423 REAL(dp) :: d_max = dp_fill !< maximum value 416 424 425 CHARACTER(LEN=lc) :: c_unt = '' !< new variables units (linked to units factor) 426 REAL(dp) :: d_unf = 1._dp !< units factor 427 417 428 !!! netcdf4 418 429 LOGICAL :: l_contiguous = .FALSE. !< use contiguous storage or not … … 518 529 !> 519 530 !> @author J.Paul 520 !> - November, 2013- Initial Version531 !> @date November, 2013 - Initial Version 521 532 !> @date November, 2014 522 533 !> - use function instead of overload assignment operator (to avoid memory leak) … … 548 559 var__copy_unit%d_min = td_var%d_min 549 560 var__copy_unit%d_max = td_var%d_max 561 562 var__copy_unit%c_unt = TRIM(td_var%c_unt) 563 var__copy_unit%d_unf = td_var%d_unf 550 564 551 565 var__copy_unit%i_type = td_var%i_type … … 577 591 var__copy_unit%c_units = TRIM(td_var%c_units) 578 592 var__copy_unit%c_axis = TRIM(td_var%c_axis) 593 var__copy_unit%d_unf = td_var%d_unf 579 594 var__copy_unit%d_scf = td_var%d_scf 580 595 var__copy_unit%d_ofs = td_var%d_ofs … … 627 642 !> 628 643 !> @author J.Paul 629 !> - November, 2013- Initial Version644 !> @date November, 2013 - Initial Version 630 645 !> @date November, 2014 631 646 !> - use function instead of overload assignment operator … … 656 671 !> 657 672 !> @author J.Paul 658 !> - November, 2013- Initial Version673 !> @date November, 2013 - Initial Version 659 674 !> 660 675 !> @param[inout] td_var variable strucutre … … 695 710 ! 696 711 !> @author J.Paul 697 !> - September, 2014- Initial Version712 !> @date September, 2014 - Initial Version 698 713 ! 699 714 !> @param[inout] td_var array of variable strucutre … … 718 733 ! 719 734 !> @author J.Paul 720 !> - September, 2014- Initial Version735 !> @date September, 2014 - Initial Version 721 736 ! 722 737 !> @param[inout] td_var array of variable strucutre … … 744 759 ! 745 760 !> @author J.Paul 746 !> - September, 2014- Initial Version761 !> @date September, 2014 - Initial Version 747 762 ! 748 763 !> @param[inout] td_var array of variable strucutre … … 788 803 !> - id_id : variable id (read from a file). 789 804 !> - id_ew : number of point composing east west wrap band. 805 !> - dd_unf : real(8) value for units factor attribute. 790 806 !> - dd_scf : real(8) value for scale factor attribute. 791 807 !> - dd_ofs : real(8) value for add offset attribute. … … 801 817 !> - cd_extrap : a array of character defining extrapolation method. 802 818 !> - cd_filter : a array of character defining filtering method. 819 !> - cd_unt : a string character to define output unit 820 !> - dd_unf : real(8) factor applied to change unit 803 821 !> 804 822 !> @note most of these optionals arguments will be inform automatically, … … 806 824 !> 807 825 !> @author J.Paul 808 !> - November, 2013- Initial Version 826 !> @date November, 2013 - Initial Version 827 !> @date February, 2015 828 !> - Bug fix: conversion of the FillValue type (float case) 829 !> @date June, 2015 830 !> - add unit factor (to change unit) 809 831 !> 810 832 !> @param[in] cd_name variable name … … 833 855 !> @param[in] cd_extrap extrapolation method 834 856 !> @param[in] cd_filter filter method 857 !> @param[in] cd_unt new units (linked to units factor) 858 !> @param[in] dd_unf units factor 835 859 !> @return variable structure 836 860 !------------------------------------------------------------------- … … 843 867 & ld_contiguous, ld_shuffle,& 844 868 & ld_fletcher32, id_deflvl, id_chunksz, & 845 & cd_interp, cd_extrap, cd_filter ) 869 & cd_interp, cd_extrap, cd_filter, & 870 & cd_unt, dd_unf ) 846 871 IMPLICIT NONE 847 872 ! Argument … … 871 896 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 872 897 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 898 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 899 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 873 900 874 901 … … 933 960 tl_att=att_init('_FillValue', INT(dd_fill,i4) ) 934 961 CASE(NF90_FLOAT) 935 tl_att=att_init('_FillValue', INT(dd_fill,sp) )962 tl_att=att_init('_FillValue', REAL(dd_fill,sp) ) 936 963 CASE DEFAULT ! NF90_DOUBLE 937 964 tl_att=att_init('_FillValue', dd_fill ) 938 965 END SELECT 939 966 CALL var_move_att(var__init, tl_att) … … 1038 1065 ENDIF 1039 1066 1067 ! units factor 1068 IF( PRESENT(dd_unf) )THEN 1069 tl_att=att_init('units_factor',dd_unf) 1070 CALL var_move_att(var__init, tl_att) 1071 ENDIF 1072 1073 ! new units (linked to units factor) 1074 IF( PRESENT(cd_unt) )THEN 1075 tl_att=att_init('new_units',cd_units) 1076 CALL var_move_att(var__init, tl_att) 1077 ENDIF 1078 1040 1079 ! add extra information 1041 1080 CALL var__get_extra(var__init) … … 1047 1086 CALL var_del_att(var__init, 'filter') 1048 1087 CALL var_del_att(var__init, 'src_file') 1088 CALL var_del_att(var__init, 'src_i_indices') 1089 CALL var_del_att(var__init, 'src_j_indices') 1049 1090 CALL var_del_att(var__init, 'valid_min') 1050 1091 CALL var_del_att(var__init, 'valid_max') … … 1072 1113 ! 1073 1114 !> @author J.Paul 1074 !> - November, 2013- Initial Version 1075 ! 1115 !> @date November, 2013 - Initial Version 1116 !> @date June, 2015 1117 !> - add interp, extrap, and filter argument 1118 !> @date July, 2015 1119 !> - add unit factor (to change unit) 1120 !> 1076 1121 !> @param[in] cd_name variable name 1077 1122 !> @param[in] dd_value 1D array of real(8) value … … 1100 1145 !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no deflation is in use 1101 1146 !> @param[in] id_chunksz chunk size 1147 !> @param[in] cd_interp interpolation method 1148 !> @param[in] cd_extrap extrapolation method 1149 !> @param[in] cd_filter filter method 1150 !> @param[in] cd_unt new units (linked to units factor) 1151 !> @param[in] dd_unf units factor 1102 1152 !> @return variable structure 1103 1153 !------------------------------------------------------------------- … … 1110 1160 & dd_min, dd_max, & 1111 1161 & ld_contiguous, ld_shuffle,& 1112 & ld_fletcher32, id_deflvl, id_chunksz) 1162 & ld_fletcher32, id_deflvl, id_chunksz, & 1163 & cd_interp, cd_extrap, cd_filter, & 1164 & cd_unt, dd_unf) 1113 1165 IMPLICIT NONE 1114 1166 ! Argument … … 1138 1190 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 1139 1191 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 1192 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 1193 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 1194 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 1195 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 1196 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 1140 1197 1141 1198 ! local variable … … 1193 1250 & ld_fletcher32=ld_fletcher32, & 1194 1251 & id_deflvl=id_deflvl, & 1195 & id_chunksz=id_chunksz(:)) 1252 & id_chunksz=id_chunksz(:), & 1253 & cd_interp=cd_interp(:), & 1254 & cd_extrap=cd_extrap(:), & 1255 & cd_filter=cd_filter(:), & 1256 & cd_unt=cd_unt, dd_unf=dd_unf ) 1196 1257 1197 1258 ! add value … … 1239 1300 ! 1240 1301 !> @author J.Paul 1241 !> - November, 2013- Initial Version 1302 !> @date November, 2013 - Initial Version 1303 !> @date February, 2015 1304 !> - bug fix: array initialise with dimension 1305 !> array not only one value 1306 !> @date June, 2015 1307 !> - add interp, extrap, and filter argument 1308 !> - Bux fix: dimension array initialise not only one value 1309 !> @date July, 2015 1310 !> - add unit factor (to change unit) 1242 1311 ! 1243 1312 !> @param[in] cd_name variable name … … 1269 1338 !> no deflation is in use 1270 1339 !> @param[in] id_chunksz chunk size 1340 !> @param[in] cd_interp interpolation method 1341 !> @param[in] cd_extrap extrapolation method 1342 !> @param[in] cd_filter filter method 1343 !> @param[in] cd_unt new units (linked to units factor) 1344 !> @param[in] dd_unf units factor 1271 1345 !> @return variable structure 1272 1346 !------------------------------------------------------------------- … … 1279 1353 & dd_min, dd_max, & 1280 1354 & ld_contiguous, ld_shuffle,& 1281 & ld_fletcher32, id_deflvl, id_chunksz) 1355 & ld_fletcher32, id_deflvl, id_chunksz, & 1356 & cd_interp, cd_extrap, cd_filter, & 1357 & cd_unt, dd_unf) 1282 1358 IMPLICIT NONE 1283 1359 ! Argument … … 1307 1383 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 1308 1384 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 1385 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 1386 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 1387 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 1388 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 1389 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 1309 1390 1310 1391 ! local variable … … 1350 1431 ENDIF 1351 1432 1352 il_count(:)=tl_dim( 1)%i_len1433 il_count(:)=tl_dim(:)%i_len 1353 1434 IF( PRESENT(id_count) )THEN 1354 1435 IF( SIZE(id_count(:)) /= 2 )THEN … … 1381 1462 & ld_fletcher32=ld_fletcher32, & 1382 1463 & id_deflvl=id_deflvl, & 1383 & id_chunksz=id_chunksz(:)) 1464 & id_chunksz=id_chunksz(:), & 1465 & cd_interp=cd_interp(:), & 1466 & cd_extrap=cd_extrap(:), & 1467 & cd_filter=cd_filter(:), & 1468 & cd_unt=cd_unt, dd_unf=dd_unf ) 1384 1469 1385 1470 ! add value … … 1431 1516 ! 1432 1517 !> @author J.Paul 1433 !> - November, 2013- Initial Version 1434 ! 1518 !> @date November, 2013 - Initial Version 1519 !> @date June, 2015 1520 !> - add interp, extrap, and filter argument 1521 !> @date July, 2015 1522 !> - add unit factor (to change unit) 1523 !> 1435 1524 !> @param[in] cd_name variable name 1436 1525 !> @param[in] dd_value 1D array of real(8) value … … 1461 1550 !> deflation is in use 1462 1551 !> @param[in] id_chunksz chunk size 1552 !> @param[in] cd_interp interpolation method 1553 !> @param[in] cd_extrap extrapolation method 1554 !> @param[in] cd_filter filter method 1555 !> @param[in] cd_unt new units (linked to units factor) 1556 !> @param[in] dd_unf units factor 1463 1557 !> @return variable structure 1464 1558 !------------------------------------------------------------------- … … 1471 1565 & dd_min, dd_max, & 1472 1566 & ld_contiguous, ld_shuffle,& 1473 & ld_fletcher32, id_deflvl, id_chunksz) 1567 & ld_fletcher32, id_deflvl, id_chunksz, & 1568 & cd_interp, cd_extrap, cd_filter, & 1569 & cd_unt, dd_unf) 1474 1570 IMPLICIT NONE 1475 1571 ! Argument … … 1499 1595 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 1500 1596 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 1597 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 1598 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 1599 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 1600 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 1601 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 1501 1602 1502 1603 ! local variable … … 1577 1678 & ld_fletcher32=ld_fletcher32, & 1578 1679 & id_deflvl=id_deflvl, & 1579 & id_chunksz=id_chunksz(:)) 1680 & id_chunksz=id_chunksz(:), & 1681 & cd_interp=cd_interp(:), & 1682 & cd_extrap=cd_extrap(:), & 1683 & cd_filter=cd_filter(:), & 1684 & cd_unt=cd_unt, dd_unf=dd_unf ) 1580 1685 1581 1686 ! add value … … 1623 1728 ! 1624 1729 !> @author J.Paul 1625 !> - November, 2013- Initial Version 1626 ! 1730 !> @date November, 2013 - Initial Version 1731 !> @date June, 2015 1732 !> - add interp, extrap, and filter argument 1733 !> @date July, 2015 1734 !> - add unit factor (to change unit) 1735 !> 1627 1736 !> @param[in] cd_name variable name 1628 1737 !> @param[in] dd_value 4D array of real(8) value … … 1653 1762 !> deflation is in use 1654 1763 !> @param[in] id_chunksz chunk size 1764 !> @param[in] cd_interp interpolation method 1765 !> @param[in] cd_extrap extrapolation method 1766 !> @param[in] cd_filter filter method 1767 !> @param[in] cd_unt new units (linked to units factor) 1768 !> @param[in] dd_unf units factor 1655 1769 !> @return variable structure 1656 1770 !------------------------------------------------------------------- … … 1663 1777 & dd_min, dd_max, & 1664 1778 & ld_contiguous, ld_shuffle,& 1665 & ld_fletcher32, id_deflvl, id_chunksz) 1779 & ld_fletcher32, id_deflvl, id_chunksz, & 1780 & cd_interp, cd_extrap, cd_filter, & 1781 & cd_unt, dd_unf ) 1666 1782 IMPLICIT NONE 1667 1783 ! Argument … … 1691 1807 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 1692 1808 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 1809 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 1810 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 1811 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 1812 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 1813 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 1693 1814 1694 1815 ! local variable … … 1723 1844 & ld_fletcher32=ld_fletcher32, & 1724 1845 & id_deflvl=id_deflvl, & 1725 & id_chunksz=id_chunksz(:)) 1846 & id_chunksz=id_chunksz(:), & 1847 & cd_interp=cd_interp(:), & 1848 & cd_extrap=cd_extrap(:), & 1849 & cd_filter=cd_filter(:), & 1850 & cd_unt=cd_unt, dd_unf=dd_unf ) 1726 1851 1727 1852 ! add value … … 1758 1883 ! 1759 1884 !> @author J.Paul 1760 !> - November, 2013- Initial Version 1885 !> @date November, 2013 - Initial Version 1886 !> @date June, 2015 1887 !> - add interp, extrap, and filter argument 1888 !> @date July, 2015 1889 !> - add unit factor (to change unit) 1761 1890 ! 1762 1891 !> @param[in] cd_name variable name … … 1788 1917 !> deflation is in use 1789 1918 !> @param[in] id_chunksz chunk size 1919 !> @param[in] cd_interp interpolation method 1920 !> @param[in] cd_extrap extrapolation method 1921 !> @param[in] cd_filter filter method 1922 !> @param[in] cd_unt new units (linked to units factor) 1923 !> @param[in] dd_unf units factor 1790 1924 !> @return variable structure 1791 1925 !------------------------------------------------------------------- … … 1798 1932 & dd_min, dd_max, & 1799 1933 & ld_contiguous, ld_shuffle,& 1800 & ld_fletcher32, id_deflvl, id_chunksz) 1934 & ld_fletcher32, id_deflvl, id_chunksz, & 1935 & cd_interp, cd_extrap, cd_filter, & 1936 & cd_unt, dd_unf) 1801 1937 1802 1938 IMPLICIT NONE … … 1827 1963 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 1828 1964 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 1965 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 1966 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 1967 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 1968 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 1969 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 1970 1829 1971 1830 1972 ! local variable … … 1870 2012 & ld_fletcher32=ld_fletcher32, & 1871 2013 & id_deflvl=id_deflvl, & 1872 & id_chunksz=id_chunksz(:)) 2014 & id_chunksz=id_chunksz(:), & 2015 & cd_interp=cd_interp(:), & 2016 & cd_extrap=cd_extrap(:), & 2017 & cd_filter=cd_filter(:), & 2018 & cd_unt=cd_unt, dd_unf=dd_unf ) 1873 2019 1874 2020 DEALLOCATE( dl_value ) … … 1892 2038 ! 1893 2039 !> @author J.Paul 1894 !> - November, 2013- Initial Version 2040 !> @date November, 2013 - Initial Version 2041 !> @date June, 2015 2042 !> - add interp, extrap, and filter argument 2043 !> @date July, 2015 2044 !> - add unit factor (to change unit) 1895 2045 ! 1896 2046 !> @param[in] cd_name : variable name … … 1922 2072 !> deflation is in use 1923 2073 !> @param[in] id_chunksz : chunk size 2074 !> @param[in] cd_interp interpolation method 2075 !> @param[in] cd_extrap extrapolation method 2076 !> @param[in] cd_filter filter method 2077 !> @param[in] cd_unt new units (linked to units factor) 2078 !> @param[in] dd_unf units factor 1924 2079 !> @return variable structure 1925 2080 !------------------------------------------------------------------- … … 1932 2087 & dd_min, dd_max, & 1933 2088 & ld_contiguous, ld_shuffle,& 1934 & ld_fletcher32, id_deflvl, id_chunksz) 2089 & ld_fletcher32, id_deflvl, id_chunksz, & 2090 & cd_interp, cd_extrap, cd_filter, & 2091 & cd_unt, dd_unf) 1935 2092 1936 2093 IMPLICIT NONE … … 1961 2118 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 1962 2119 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 2120 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 2121 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 2122 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 2123 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 2124 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 1963 2125 1964 2126 ! local variable … … 2006 2168 & ld_fletcher32=ld_fletcher32, & 2007 2169 & id_deflvl=id_deflvl, & 2008 & id_chunksz=id_chunksz(:)) 2170 & id_chunksz=id_chunksz(:), & 2171 & cd_interp=cd_interp(:), & 2172 & cd_extrap=cd_extrap(:), & 2173 & cd_filter=cd_filter(:), & 2174 & cd_unt=cd_unt, dd_unf=dd_unf ) 2009 2175 2010 2176 DEALLOCATE( dl_value ) … … 2028 2194 ! 2029 2195 !> @author J.Paul 2030 !> - November, 2013- Initial Version 2196 !> @date November, 2013 - Initial Version 2197 !> @date June, 2015 2198 !> - add interp, extrap, and filter argument 2199 !> @date July, 2015 2200 !> - add unit factor (to change unit) 2031 2201 ! 2032 2202 !> @param[in] cd_name : variable name … … 2058 2228 !> deflation is in use 2059 2229 !> @param[in] id_chunksz : chunk size 2230 !> @param[in] cd_interp interpolation method 2231 !> @param[in] cd_extrap extrapolation method 2232 !> @param[in] cd_filter filter method 2233 !> @param[in] cd_unt new units (linked to units factor) 2234 !> @param[in] dd_unf units factor 2060 2235 !> @return variable structure 2061 2236 !------------------------------------------------------------------- … … 2068 2243 & dd_min, dd_max, & 2069 2244 & ld_contiguous, ld_shuffle,& 2070 & ld_fletcher32, id_deflvl, id_chunksz) 2245 & ld_fletcher32, id_deflvl, id_chunksz, & 2246 & cd_interp, cd_extrap, cd_filter, & 2247 & cd_unt, dd_unf) 2071 2248 2072 2249 IMPLICIT NONE … … 2097 2274 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 2098 2275 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 2276 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 2277 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 2278 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 2279 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 2280 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 2099 2281 2100 2282 ! local variable … … 2143 2325 & ld_fletcher32=ld_fletcher32, & 2144 2326 & id_deflvl=id_deflvl, & 2145 & id_chunksz=id_chunksz(:)) 2327 & id_chunksz=id_chunksz(:), & 2328 & cd_interp=cd_interp(:), & 2329 & cd_extrap=cd_extrap(:), & 2330 & cd_filter=cd_filter(:), & 2331 & cd_unt=cd_unt, dd_unf=dd_unf) 2146 2332 2147 2333 DEALLOCATE( dl_value ) … … 2165 2351 ! 2166 2352 !> @author J.Paul 2167 !> - November, 2013- Initial Version 2353 !> @date November, 2013 - Initial Version 2354 !> @date June, 2015 2355 !> - add interp, extrap, and filter argument 2356 !> @date July, 2015 2357 !> - add unit factor (to change unit) 2168 2358 ! 2169 2359 !> @param[in] cd_name variable name … … 2195 2385 !> deflation is in use 2196 2386 !> @param[in] id_chunksz chunk size 2387 !> @param[in] cd_interp interpolation method 2388 !> @param[in] cd_extrap extrapolation method 2389 !> @param[in] cd_filter filter method 2390 !> @param[in] cd_unt new units (linked to units factor) 2391 !> @param[in] dd_unf units factor 2197 2392 !> @return variable structure 2198 2393 !------------------------------------------------------------------- … … 2205 2400 & dd_min, dd_max, & 2206 2401 & ld_contiguous, ld_shuffle,& 2207 & ld_fletcher32, id_deflvl, id_chunksz) 2402 & ld_fletcher32, id_deflvl, id_chunksz, & 2403 & cd_interp, cd_extrap, cd_filter, & 2404 & cd_unt, dd_unf) 2208 2405 2209 2406 IMPLICIT NONE … … 2234 2431 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 2235 2432 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 2433 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 2434 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 2435 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 2436 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 2437 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 2236 2438 2237 2439 ! local variable … … 2281 2483 & ld_fletcher32=ld_fletcher32, & 2282 2484 & id_deflvl=id_deflvl, & 2283 & id_chunksz=id_chunksz(:)) 2485 & id_chunksz=id_chunksz(:), & 2486 & cd_interp=cd_interp(:), & 2487 & cd_extrap=cd_extrap(:), & 2488 & cd_filter=cd_filter(:), & 2489 & cd_unt=cd_unt, dd_unf=dd_unf) 2284 2490 2285 2491 DEALLOCATE( dl_value ) … … 2303 2509 ! 2304 2510 !> @author J.Paul 2305 !> - November, 2013- Initial Version 2511 !> @date November, 2013 - Initial Version 2512 !> @date June, 2015 2513 !> - add interp, extrap, and filter argument 2514 !> @date July, 2015 2515 !> - add unit factor (to change unit) 2306 2516 ! 2307 2517 !> @param[in] cd_name : variable name … … 2333 2543 !> deflation is in use 2334 2544 !> @param[in] id_chunksz : chunk size 2545 !> @param[in] cd_interp interpolation method 2546 !> @param[in] cd_extrap extrapolation method 2547 !> @param[in] cd_filter filter method 2548 !> @param[in] cd_unt new units (linked to units factor) 2549 !> @param[in] dd_unf units factor 2335 2550 !> @return variable structure 2336 2551 !------------------------------------------------------------------- … … 2343 2558 & dd_min, dd_max, & 2344 2559 & ld_contiguous, ld_shuffle,& 2345 & ld_fletcher32, id_deflvl, id_chunksz) 2560 & ld_fletcher32, id_deflvl, id_chunksz, & 2561 & cd_interp, cd_extrap, cd_filter, & 2562 & cd_unt, dd_unf) 2346 2563 2347 2564 IMPLICIT NONE … … 2372 2589 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 2373 2590 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 2591 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 2592 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 2593 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 2594 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 2595 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 2374 2596 2375 2597 ! local variable … … 2415 2637 & ld_fletcher32=ld_fletcher32, & 2416 2638 & id_deflvl=id_deflvl, & 2417 & id_chunksz=id_chunksz(:)) 2639 & id_chunksz=id_chunksz(:), & 2640 & cd_interp=cd_interp(:), & 2641 & cd_extrap=cd_extrap(:), & 2642 & cd_filter=cd_filter(:), & 2643 & cd_unt=cd_unt, dd_unf=dd_unf) 2418 2644 2419 2645 DEALLOCATE( dl_value ) … … 2437 2663 ! 2438 2664 !> @author J.Paul 2439 !> - November, 2013- Initial Version 2665 !> @date November, 2013 - Initial Version 2666 !> @date June, 2015 2667 !> - add interp, extrap, and filter argument 2668 !> @date July, 2015 2669 !> - add unit factor (to change unit) 2440 2670 ! 2441 2671 !> @param[in] cd_name variable name … … 2465 2695 !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no deflation is in use 2466 2696 !> @param[in] id_chunksz chunk size 2697 !> @param[in] cd_interp interpolation method 2698 !> @param[in] cd_extrap extrapolation method 2699 !> @param[in] cd_filter filter method 2700 !> @param[in] cd_unt new units (linked to units factor) 2701 !> @param[in] dd_unf units factor 2467 2702 !> @return variable structure 2468 2703 !------------------------------------------------------------------- … … 2475 2710 & dd_min, dd_max, & 2476 2711 & ld_contiguous, ld_shuffle,& 2477 & ld_fletcher32, id_deflvl, id_chunksz) 2712 & ld_fletcher32, id_deflvl, id_chunksz, & 2713 & cd_interp, cd_extrap, cd_filter, & 2714 & cd_unt, dd_unf) 2478 2715 2479 2716 IMPLICIT NONE … … 2504 2741 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 2505 2742 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 2743 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 2744 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 2745 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 2746 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 2747 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 2506 2748 2507 2749 ! local variable … … 2549 2791 & ld_fletcher32=ld_fletcher32, & 2550 2792 & id_deflvl=id_deflvl, & 2551 & id_chunksz=id_chunksz(:)) 2793 & id_chunksz=id_chunksz(:), & 2794 & cd_interp=cd_interp(:), & 2795 & cd_extrap=cd_extrap(:), & 2796 & cd_filter=cd_filter(:), & 2797 & cd_unt=cd_unt, dd_unf=dd_unf) 2552 2798 2553 2799 DEALLOCATE( dl_value ) … … 2571 2817 ! 2572 2818 !> @author J.Paul 2573 !> - November, 2013- Initial Version 2819 !> @date November, 2013 - Initial Version 2820 !> @date June, 2015 2821 !> - add interp, extrap, and filter argument 2822 !> @date July, 2015 2823 !> - add unit factor (to change unit) 2574 2824 ! 2575 2825 !> @param[in] cd_name variable name … … 2601 2851 !> deflation is in use 2602 2852 !> @param[in] id_chunksz chunk size 2853 !> @param[in] cd_interp interpolation method 2854 !> @param[in] cd_extrap extrapolation method 2855 !> @param[in] cd_filter filter method 2856 !> @param[in] cd_unt new units (linked to units factor) 2857 !> @param[in] dd_unf units factor 2603 2858 !> @return variable structure 2604 2859 !------------------------------------------------------------------- … … 2611 2866 & dd_min, dd_max, & 2612 2867 & ld_contiguous, ld_shuffle,& 2613 & ld_fletcher32, id_deflvl, id_chunksz) 2868 & ld_fletcher32, id_deflvl, id_chunksz, & 2869 & cd_interp, cd_extrap, cd_filter, & 2870 & cd_unt, dd_unf) 2614 2871 2615 2872 IMPLICIT NONE … … 2640 2897 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 2641 2898 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 2899 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 2900 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 2901 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 2902 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 2903 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 2642 2904 2643 2905 ! local variable … … 2686 2948 & ld_fletcher32=ld_fletcher32, & 2687 2949 & id_deflvl=id_deflvl, & 2688 & id_chunksz=id_chunksz(:)) 2950 & id_chunksz=id_chunksz(:), & 2951 & cd_interp=cd_interp(:), & 2952 & cd_extrap=cd_extrap(:), & 2953 & cd_filter=cd_filter(:), & 2954 & cd_unt=cd_unt, dd_unf=dd_unf) 2689 2955 2690 2956 DEALLOCATE( dl_value ) … … 2708 2974 ! 2709 2975 !> @author J.Paul 2710 !> - November, 2013- Initial Version 2976 !> @date November, 2013 - Initial Version 2977 !> @date June, 2015 2978 !> - add interp, extrap, and filter argument 2979 !> @date July, 2015 2980 !> - add unit factor (to change unit) 2711 2981 ! 2712 2982 !> @param[in] cd_name variable name … … 2738 3008 !> deflation is in use 2739 3009 !> @param[in] id_chunksz chunk size 3010 !> @param[in] cd_interp interpolation method 3011 !> @param[in] cd_extrap extrapolation method 3012 !> @param[in] cd_filter filter method 3013 !> @param[in] cd_unt new units (linked to units factor) 3014 !> @param[in] dd_unf units factor 2740 3015 !> @return variable structure 2741 3016 !------------------------------------------------------------------- … … 2748 3023 & dd_min, dd_max, & 2749 3024 & ld_contiguous, ld_shuffle,& 2750 & ld_fletcher32, id_deflvl, id_chunksz) 3025 & ld_fletcher32, id_deflvl, id_chunksz, & 3026 & cd_interp, cd_extrap, cd_filter, & 3027 & cd_unt, dd_unf) 2751 3028 2752 3029 IMPLICIT NONE … … 2777 3054 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 2778 3055 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 3056 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 3057 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 3058 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 3059 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 3060 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 3061 2779 3062 2780 3063 ! local variable … … 2824 3107 & ld_fletcher32=ld_fletcher32, & 2825 3108 & id_deflvl=id_deflvl, & 2826 & id_chunksz=id_chunksz(:)) 3109 & id_chunksz=id_chunksz(:), & 3110 & cd_interp=cd_interp(:), & 3111 & cd_extrap=cd_extrap(:), & 3112 & cd_filter=cd_filter(:), & 3113 & cd_unt=cd_unt, dd_unf=dd_unf) 2827 3114 2828 3115 DEALLOCATE( dl_value ) … … 2846 3133 ! 2847 3134 !> @author J.Paul 2848 !> - November, 2013- Initial Version 3135 !> @date November, 2013 - Initial Version 3136 !> @date June, 2015 3137 !> - add interp, extrap, and filter argument 3138 !> @date July, 2015 3139 !> - add unit factor (to change unit) 2849 3140 ! 2850 3141 !> @param[in] cd_name variable name … … 2876 3167 !> deflation is in use 2877 3168 !> @param[in] id_chunksz chunk size 3169 !> @param[in] cd_interp interpolation method 3170 !> @param[in] cd_extrap extrapolation method 3171 !> @param[in] cd_filter filter method 3172 !> @param[in] cd_unt new units (linked to units factor) 3173 !> @param[in] dd_unf units factor 2878 3174 !> @return variable structure 2879 3175 !------------------------------------------------------------------- … … 2886 3182 & dd_min, dd_max, & 2887 3183 & ld_contiguous, ld_shuffle,& 2888 & ld_fletcher32, id_deflvl, id_chunksz) 3184 & ld_fletcher32, id_deflvl, id_chunksz, & 3185 & cd_interp, cd_extrap, cd_filter, & 3186 & cd_unt, dd_unf) 2889 3187 2890 3188 IMPLICIT NONE … … 2915 3213 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 2916 3214 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 3215 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 3216 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 3217 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 3218 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 3219 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 2917 3220 2918 3221 ! local variable … … 2958 3261 & ld_fletcher32=ld_fletcher32, & 2959 3262 & id_deflvl=id_deflvl, & 2960 & id_chunksz=id_chunksz(:)) 3263 & id_chunksz=id_chunksz(:), & 3264 & cd_interp=cd_interp(:), & 3265 & cd_extrap=cd_extrap(:), & 3266 & cd_filter=cd_filter(:), & 3267 & cd_unt=cd_unt, dd_unf=dd_unf) 2961 3268 2962 3269 DEALLOCATE( dl_value ) … … 2980 3287 ! 2981 3288 !> @author J.Paul 2982 !> - November, 2013- Initial Version 3289 !> @date November, 2013 - Initial Version 3290 !> @date June, 2015 3291 !> - add interp, extrap, and filter argument 3292 !> @date July, 2015 3293 !> - add unit factor (to change unit) 2983 3294 ! 2984 3295 !> @param[in] cd_name variable name … … 3010 3321 !> deflation is in use 3011 3322 !> @param[in] id_chunksz chunk size 3323 !> @param[in] cd_interp interpolation method 3324 !> @param[in] cd_extrap extrapolation method 3325 !> @param[in] cd_filter filter method 3326 !> @param[in] cd_unt new units (linked to units factor) 3327 !> @param[in] dd_unf units factor 3012 3328 !> @return variable structure 3013 3329 !------------------------------------------------------------------- … … 3020 3336 & dd_min, dd_max, & 3021 3337 & ld_contiguous, ld_shuffle,& 3022 & ld_fletcher32, id_deflvl, id_chunksz) 3338 & ld_fletcher32, id_deflvl, id_chunksz, & 3339 & cd_interp, cd_extrap, cd_filter, & 3340 & cd_unt, dd_unf) 3023 3341 3024 3342 IMPLICIT NONE … … 3049 3367 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 3050 3368 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 3369 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 3370 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 3371 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 3372 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 3373 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 3051 3374 3052 3375 ! local variable … … 3094 3417 & ld_fletcher32=ld_fletcher32, & 3095 3418 & id_deflvl=id_deflvl, & 3096 & id_chunksz=id_chunksz(:)) 3419 & id_chunksz=id_chunksz(:), & 3420 & cd_interp=cd_interp(:), & 3421 & cd_extrap=cd_extrap(:), & 3422 & cd_filter=cd_filter(:), & 3423 & cd_unt=cd_unt, dd_unf=dd_unf) 3097 3424 3098 3425 DEALLOCATE( dl_value ) … … 3116 3443 ! 3117 3444 !> @author J.Paul 3118 !> - November, 2013- Initial Version 3445 !> @date November, 2013 - Initial Version 3446 !> @date June, 2015 3447 !> - add interp, extrap, and filter argument 3448 !> @date July, 2015 3449 !> - add unit factor (to change unit) 3119 3450 ! 3120 3451 !> @param[in] cd_name variable name … … 3146 3477 !> deflation is in use 3147 3478 !> @param[in] id_chunksz chunk size 3479 !> @param[in] cd_interp interpolation method 3480 !> @param[in] cd_extrap extrapolation method 3481 !> @param[in] cd_filter filter method 3482 !> @param[in] cd_unt new units (linked to units factor) 3483 !> @param[in] dd_unf units factor 3148 3484 !> @return variable structure 3149 3485 !------------------------------------------------------------------- … … 3156 3492 & dd_min, dd_max, & 3157 3493 & ld_contiguous, ld_shuffle,& 3158 & ld_fletcher32, id_deflvl, id_chunksz) 3494 & ld_fletcher32, id_deflvl, id_chunksz, & 3495 & cd_interp, cd_extrap, cd_filter, & 3496 & cd_unt, dd_unf) 3159 3497 3160 3498 IMPLICIT NONE … … 3185 3523 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 3186 3524 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 3525 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 3526 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 3527 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 3528 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 3529 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 3187 3530 3188 3531 ! local variable … … 3231 3574 & ld_fletcher32=ld_fletcher32, & 3232 3575 & id_deflvl=id_deflvl, & 3233 & id_chunksz=id_chunksz(:)) 3576 & id_chunksz=id_chunksz(:), & 3577 & cd_interp=cd_interp(:), & 3578 & cd_extrap=cd_extrap(:), & 3579 & cd_filter=cd_filter(:), & 3580 & cd_unt=cd_unt, dd_unf=dd_unf) 3234 3581 3235 3582 DEALLOCATE( dl_value ) … … 3253 3600 ! 3254 3601 !> @author J.Paul 3255 !> - November, 2013- Initial Version 3602 !> @date November, 2013 - Initial Version 3603 !> @date June, 2015 3604 !> - add interp, extrap, and filter argument 3605 !> @date July, 2015 3606 !> - add unit factor (to change unit) 3256 3607 ! 3257 3608 !> @param[in] cd_name variable name … … 3283 3634 !> deflation is in use 3284 3635 !> @param[in] id_chunksz chunk size 3636 !> @param[in] cd_interp interpolation method 3637 !> @param[in] cd_extrap extrapolation method 3638 !> @param[in] cd_filter filter method 3639 !> @param[in] cd_unt new units (linked to units factor) 3640 !> @param[in] dd_unf units factor 3641 3285 3642 !> @return variable structure 3286 3643 !------------------------------------------------------------------- … … 3293 3650 & dd_min, dd_max, & 3294 3651 & ld_contiguous, ld_shuffle,& 3295 & ld_fletcher32, id_deflvl, id_chunksz) 3652 & ld_fletcher32, id_deflvl, id_chunksz, & 3653 & cd_interp, cd_extrap, cd_filter, & 3654 & cd_unt, dd_unf) 3296 3655 3297 3656 IMPLICIT NONE … … 3322 3681 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 3323 3682 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 3683 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 3684 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 3685 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 3686 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 3687 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 3324 3688 3325 3689 ! local variable … … 3369 3733 & ld_fletcher32=ld_fletcher32, & 3370 3734 & id_deflvl=id_deflvl, & 3371 & id_chunksz=id_chunksz(:)) 3735 & id_chunksz=id_chunksz(:), & 3736 & cd_interp=cd_interp(:), & 3737 & cd_extrap=cd_extrap(:), & 3738 & cd_filter=cd_filter(:), & 3739 & cd_unt=cd_unt, dd_unf=dd_unf) 3372 3740 3373 3741 DEALLOCATE( dl_value ) … … 3391 3759 ! 3392 3760 !> @author J.Paul 3393 !> - November, 2013- Initial Version 3761 !> @date November, 2013 - Initial Version 3762 !> @date June, 2015 3763 !> - add interp, extrap, and filter argument 3764 !> @date July, 2015 3765 !> - add unit factor (to change unit) 3394 3766 ! 3395 3767 !> @param[in] cd_name variable name … … 3421 3793 !> deflation is in use 3422 3794 !> @param[in] id_chunksz chunk size 3795 !> @param[in] cd_interp interpolation method 3796 !> @param[in] cd_extrap extrapolation method 3797 !> @param[in] cd_filter filter method 3798 !> @param[in] cd_unt new units (linked to units factor) 3799 !> @param[in] dd_unf units factor 3423 3800 !> @return variable structure 3424 3801 !------------------------------------------------------------------- … … 3431 3808 & dd_min, dd_max, & 3432 3809 & ld_contiguous, ld_shuffle,& 3433 & ld_fletcher32, id_deflvl, id_chunksz) 3810 & ld_fletcher32, id_deflvl, id_chunksz, & 3811 & cd_interp, cd_extrap, cd_filter, & 3812 & cd_unt, dd_unf) 3434 3813 3435 3814 IMPLICIT NONE … … 3460 3839 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 3461 3840 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 3841 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 3842 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 3843 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 3844 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 3845 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 3846 3462 3847 3463 3848 ! local variable … … 3503 3888 & ld_fletcher32=ld_fletcher32, & 3504 3889 & id_deflvl=id_deflvl, & 3505 & id_chunksz=id_chunksz(:)) 3890 & id_chunksz=id_chunksz(:), & 3891 & cd_interp=cd_interp(:), & 3892 & cd_extrap=cd_extrap(:), & 3893 & cd_filter=cd_filter(:), & 3894 & cd_unt=cd_unt, dd_unf=dd_unf) 3506 3895 3507 3896 DEALLOCATE( dl_value ) … … 3525 3914 ! 3526 3915 !> @author J.Paul 3527 !> - November, 2013- Initial Version 3916 !> @date November, 2013 - Initial Version 3917 !> @date June, 2015 3918 !> - add interp, extrap, and filter argument 3919 !> @date July, 2015 3920 !> - add unit factor (to change unit) 3528 3921 ! 3529 3922 !> @param[in] cd_name variable name … … 3555 3948 !> deflation is in use 3556 3949 !> @param[in] id_chunksz chunk size 3950 !> @param[in] cd_interp interpolation method 3951 !> @param[in] cd_extrap extrapolation method 3952 !> @param[in] cd_filter filter method 3953 !> @param[in] cd_unt new units (linked to units factor) 3954 !> @param[in] dd_unf units factor 3557 3955 !> @return variable structure 3558 3956 !------------------------------------------------------------------- … … 3565 3963 & dd_min, dd_max, & 3566 3964 & ld_contiguous, ld_shuffle,& 3567 & ld_fletcher32, id_deflvl, id_chunksz) 3965 & ld_fletcher32, id_deflvl, id_chunksz, & 3966 & cd_interp, cd_extrap, cd_filter, & 3967 & cd_unt, dd_unf) 3568 3968 3569 3969 IMPLICIT NONE … … 3594 3994 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 3595 3995 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 3996 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 3997 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 3998 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 3999 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 4000 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 4001 3596 4002 3597 4003 ! local variable … … 3639 4045 & ld_fletcher32=ld_fletcher32, & 3640 4046 & id_deflvl=id_deflvl, & 3641 & id_chunksz=id_chunksz(:)) 4047 & id_chunksz=id_chunksz(:), & 4048 & cd_interp=cd_interp(:), & 4049 & cd_extrap=cd_extrap(:), & 4050 & cd_filter=cd_filter(:), & 4051 & cd_unt=cd_unt, dd_unf=dd_unf) 3642 4052 3643 4053 DEALLOCATE( dl_value ) … … 3661 4071 ! 3662 4072 !> @author J.Paul 3663 !> - November, 2013- Initial Version 4073 !> @date November, 2013 - Initial Version 4074 !> @date June, 2015 4075 !> - add interp, extrap, and filter argument 4076 !> @date July, 2015 4077 !> - add unit factor (to change unit) 3664 4078 ! 3665 4079 !> @param[in] cd_name variable name … … 3691 4105 !> deflation is in use 3692 4106 !> @param[in] id_chunksz chunk size 4107 !> @param[in] cd_interp interpolation method 4108 !> @param[in] cd_extrap extrapolation method 4109 !> @param[in] cd_filter filter method 4110 !> @param[in] cd_unt new units (linked to units factor) 4111 !> @param[in] dd_unf units factor 3693 4112 !> @return variable structure 3694 4113 !------------------------------------------------------------------- … … 3701 4120 & dd_min, dd_max, & 3702 4121 & ld_contiguous, ld_shuffle,& 3703 & ld_fletcher32, id_deflvl, id_chunksz) 4122 & ld_fletcher32, id_deflvl, id_chunksz, & 4123 & cd_interp, cd_extrap, cd_filter, & 4124 & cd_unt, dd_unf) 3704 4125 3705 4126 IMPLICIT NONE … … 3730 4151 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 3731 4152 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 4153 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 4154 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 4155 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 4156 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 4157 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 3732 4158 3733 4159 ! local variable … … 3776 4202 & ld_fletcher32=ld_fletcher32, & 3777 4203 & id_deflvl=id_deflvl, & 3778 & id_chunksz=id_chunksz(:)) 4204 & id_chunksz=id_chunksz(:), & 4205 & cd_interp=cd_interp(:), & 4206 & cd_extrap=cd_extrap(:), & 4207 & cd_filter=cd_filter(:), & 4208 & cd_unt=cd_unt, dd_unf=dd_unf) 3779 4209 3780 4210 DEALLOCATE( dl_value ) … … 3798 4228 ! 3799 4229 !> @author J.Paul 3800 !> - November, 2013- Initial Version 4230 !> @date November, 2013 - Initial Version 4231 !> @date June, 2015 4232 !> - add interp, extrap, and filter argument 4233 !> @date July, 2015 4234 !> - add unit factor (to change unit) 3801 4235 ! 3802 4236 !> @param[in] cd_name variable name … … 3828 4262 !> deflation is in use 3829 4263 !> @param[in] id_chunksz chunk size 4264 !> @param[in] cd_interp interpolation method 4265 !> @param[in] cd_extrap extrapolation method 4266 !> @param[in] cd_filter filter method 4267 !> @param[in] cd_unt new units (linked to units factor) 4268 !> @param[in] dd_unf units factor 3830 4269 !> @return variable structure 3831 4270 !------------------------------------------------------------------- … … 3838 4277 & dd_min, dd_max, & 3839 4278 & ld_contiguous, ld_shuffle,& 3840 & ld_fletcher32, id_deflvl, id_chunksz) 4279 & ld_fletcher32, id_deflvl, id_chunksz, & 4280 & cd_interp, cd_extrap, cd_filter, & 4281 & cd_unt, dd_unf) 3841 4282 3842 4283 IMPLICIT NONE … … 3867 4308 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 3868 4309 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 4310 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 4311 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 4312 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 4313 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 4314 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 3869 4315 3870 4316 ! local variable … … 3914 4360 & ld_fletcher32=ld_fletcher32, & 3915 4361 & id_deflvl=id_deflvl, & 3916 & id_chunksz=id_chunksz(:)) 4362 & id_chunksz=id_chunksz(:), & 4363 & cd_interp=cd_interp(:), & 4364 & cd_extrap=cd_extrap(:), & 4365 & cd_filter=cd_filter(:), & 4366 & cd_unt=cd_unt, dd_unf=dd_unf) 3917 4367 3918 4368 DEALLOCATE( dl_value ) … … 3936 4386 ! 3937 4387 !> @author J.Paul 3938 !> - November, 2013- Initial Version 4388 !> @date November, 2013 - Initial Version 4389 !> @date June, 2015 4390 !> - add interp, extrap, and filter argument 4391 !> @date July, 2015 4392 !> - add unit factor (to change unit) 3939 4393 ! 3940 4394 !> @param[in] cd_name variable name … … 3966 4420 !> deflation is in use 3967 4421 !> @param[in] id_chunksz chunk size 4422 !> @param[in] cd_interp interpolation method 4423 !> @param[in] cd_extrap extrapolation method 4424 !> @param[in] cd_filter filter method 4425 !> @param[in] cd_unt new units (linked to units factor) 4426 !> @param[in] dd_unf units factor 3968 4427 !> @return variable structure 3969 4428 !------------------------------------------------------------------- … … 3976 4435 & dd_min, dd_max, & 3977 4436 & ld_contiguous, ld_shuffle,& 3978 & ld_fletcher32, id_deflvl, id_chunksz) 4437 & ld_fletcher32, id_deflvl, id_chunksz, & 4438 & cd_interp, cd_extrap, cd_filter, & 4439 & cd_unt, dd_unf) 3979 4440 3980 4441 IMPLICIT NONE … … 4005 4466 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 4006 4467 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 4468 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 4469 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 4470 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 4471 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 4472 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 4007 4473 4008 4474 ! local variable … … 4048 4514 & ld_fletcher32=ld_fletcher32, & 4049 4515 & id_deflvl=id_deflvl, & 4050 & id_chunksz=id_chunksz(:)) 4516 & id_chunksz=id_chunksz(:), & 4517 & cd_interp=cd_interp(:), & 4518 & cd_extrap=cd_extrap(:), & 4519 & cd_filter=cd_filter(:), & 4520 & cd_unt=cd_unt, dd_unf=dd_unf) 4051 4521 4052 4522 DEALLOCATE( dl_value ) … … 4070 4540 ! 4071 4541 !> @author J.Paul 4072 !> - November, 2013- Initial Version 4542 !> @date November, 2013 - Initial Version 4543 !> @date June, 2015 4544 !> - add interp, extrap, and filter argument 4545 !> @date July, 2015 4546 !> - add unit factor (to change unit) 4073 4547 ! 4074 4548 !> @param[in] cd_name variable name … … 4100 4574 !> deflation is in use 4101 4575 !> @param[in] id_chunksz chunk size 4576 !> @param[in] cd_interp interpolation method 4577 !> @param[in] cd_extrap extrapolation method 4578 !> @param[in] cd_filter filter method 4579 !> @param[in] cd_unt new units (linked to units factor) 4580 !> @param[in] dd_unf units factor 4102 4581 !> @return variable structure 4103 4582 !------------------------------------------------------------------- … … 4110 4589 & dd_min, dd_max, & 4111 4590 & ld_contiguous, ld_shuffle,& 4112 & ld_fletcher32, id_deflvl, id_chunksz) 4591 & ld_fletcher32, id_deflvl, id_chunksz, & 4592 & cd_interp, cd_extrap, cd_filter, & 4593 & cd_unt, dd_unf) 4113 4594 4114 4595 IMPLICIT NONE … … 4139 4620 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 4140 4621 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 4622 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 4623 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 4624 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 4625 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 4626 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 4141 4627 4142 4628 ! local variable … … 4184 4670 & ld_fletcher32=ld_fletcher32, & 4185 4671 & id_deflvl=id_deflvl, & 4186 & id_chunksz=id_chunksz(:)) 4672 & id_chunksz=id_chunksz(:), & 4673 & cd_interp=cd_interp(:), & 4674 & cd_extrap=cd_extrap(:), & 4675 & cd_filter=cd_filter(:), & 4676 & cd_unt=cd_unt, dd_unf=dd_unf) 4187 4677 4188 4678 DEALLOCATE( dl_value ) … … 4206 4696 ! 4207 4697 !> @author J.Paul 4208 !> - November, 2013- Initial Version 4698 !> @date November, 2013 - Initial Version 4699 !> @date June, 2015 4700 !> - add interp, extrap, and filter argument 4701 !> @date July, 2015 4702 !> - add unit factor (to change unit) 4209 4703 ! 4210 4704 !> @param[in] cd_name variable name … … 4236 4730 !> deflation is in use 4237 4731 !> @param[in] id_chunksz chunk size 4732 !> @param[in] cd_interp interpolation method 4733 !> @param[in] cd_extrap extrapolation method 4734 !> @param[in] cd_filter filter method 4735 !> @param[in] cd_unt new units (linked to units factor) 4736 !> @param[in] dd_unf units factor 4238 4737 !> @return variable structure 4239 4738 !------------------------------------------------------------------- … … 4246 4745 & dd_min, dd_max, & 4247 4746 & ld_contiguous, ld_shuffle,& 4248 & ld_fletcher32, id_deflvl, id_chunksz) 4747 & ld_fletcher32, id_deflvl, id_chunksz, & 4748 & cd_interp, cd_extrap, cd_filter, & 4749 & cd_unt, dd_unf) 4249 4750 4250 4751 IMPLICIT NONE … … 4275 4776 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 4276 4777 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 4778 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 4779 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 4780 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 4781 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 4782 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 4277 4783 4278 4784 ! local variable … … 4321 4827 & ld_fletcher32=ld_fletcher32, & 4322 4828 & id_deflvl=id_deflvl, & 4323 & id_chunksz=id_chunksz(:)) 4829 & id_chunksz=id_chunksz(:), & 4830 & cd_interp=cd_interp(:), & 4831 & cd_extrap=cd_extrap(:), & 4832 & cd_filter=cd_filter(:), & 4833 & cd_unt=cd_unt, dd_unf=dd_unf) 4324 4834 4325 4835 DEALLOCATE( dl_value ) … … 4343 4853 ! 4344 4854 !> @author J.Paul 4345 !> - November, 2013- Initial Version 4855 !> @date November, 2013 - Initial Version 4856 !> @date June, 2015 4857 !> - add interp, extrap, and filter argument 4858 !> @date July, 2015 4859 !> - add unit factor (to change unit) 4346 4860 ! 4347 4861 !> @param[in] cd_name variable name … … 4373 4887 !> deflation is in use 4374 4888 !> @param[in] id_chunksz chunk size 4889 !> @param[in] cd_interp interpolation method 4890 !> @param[in] cd_extrap extrapolation method 4891 !> @param[in] cd_filter filter method 4892 !> @param[in] cd_unt new units (linked to units factor) 4893 !> @param[in] dd_unf units factor 4375 4894 !> @return variable structure 4376 4895 !------------------------------------------------------------------- … … 4383 4902 & dd_min, dd_max, & 4384 4903 & ld_contiguous, ld_shuffle,& 4385 & ld_fletcher32, id_deflvl, id_chunksz) 4904 & ld_fletcher32, id_deflvl, id_chunksz, & 4905 & cd_interp, cd_extrap, cd_filter, & 4906 & cd_unt, dd_unf) 4386 4907 4387 4908 IMPLICIT NONE … … 4412 4933 INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl 4413 4934 INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz 4935 CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp 4936 CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap 4937 CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter 4938 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt 4939 REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf 4414 4940 4415 4941 ! local variable … … 4459 4985 & ld_fletcher32=ld_fletcher32, & 4460 4986 & id_deflvl=id_deflvl, & 4461 & id_chunksz=id_chunksz(:)) 4987 & id_chunksz=id_chunksz(:), & 4988 & cd_interp=cd_interp(:), & 4989 & cd_extrap=cd_extrap(:), & 4990 & cd_filter=cd_filter(:), & 4991 & cd_unt=cd_unt, dd_unf=dd_unf) 4462 4992 4463 4993 DEALLOCATE( dl_value ) … … 4473 5003 !> 4474 5004 !> @author J.Paul 4475 !> - November, 2013- Initial Version5005 !> @date November, 2013 - Initial Version 4476 5006 ! 4477 5007 !> @param[in] td_var1 variable structure … … 4523 5053 !> 4524 5054 !> @author J.Paul 4525 !> - November, 2013- Initial Version5055 !> @date November, 2013 - Initial Version 4526 5056 ! 4527 5057 !> @param[in] td_var1 variable structure … … 4595 5125 !> 4596 5126 !> @author J.Paul 4597 !> - November, 2013- Initial Version5127 !> @date November, 2013 - Initial Version 4598 5128 ! 4599 5129 !> @param[in] td_var1 variable structure … … 4670 5200 !> 4671 5201 !> @author J.Paul 4672 !> - November, 2013- Initial Version5202 !> @date November, 2013 - Initial Version 4673 5203 ! 4674 5204 !> @param[in] td_var1 variable structure … … 4745 5275 !> 4746 5276 !> @author J.Paul 4747 !> - November, 2013- Initial Version5277 !> @date November, 2013 - Initial Version 4748 5278 ! 4749 5279 !> @param[in] td_var1 variable structure … … 4820 5350 !> 4821 5351 !> @author J.Paul 4822 !> - November, 2013- Initial Version 5352 !> @date November, 2013 - Initial Version 5353 !> @date June, 2015 5354 !> - add all element of the array in the same time 4823 5355 !> 4824 5356 !> @param[inout] td_var variable structure … … 4833 5365 ! local variable 4834 5366 INTEGER(i4) :: il_natt 5367 INTEGER(i4) :: il_status 5368 INTEGER(i4) :: il_ind 5369 TYPE(TATT), DIMENSION(:), ALLOCATABLE :: tl_att 4835 5370 4836 5371 ! loop indices … … 4840 5375 il_natt=SIZE(td_att(:)) 4841 5376 5377 IF( td_var%i_natt > 0 )THEN 5378 ! already other attribute in variable structure 5379 ALLOCATE( tl_att(td_var%i_natt), stat=il_status ) 5380 IF(il_status /= 0 )THEN 5381 5382 CALL logger_error( & 5383 & " VAR ADD ATT: not enough space to put attributes from "//& 5384 & TRIM(td_var%c_name)//" in temporary attribute structure") 5385 5386 ELSE 5387 5388 ! save temporary global attribute's variable structure 5389 tl_att(:)=att_copy(td_var%t_att(:)) 5390 5391 CALL att_clean(td_var%t_att(:)) 5392 DEALLOCATE( td_var%t_att ) 5393 ALLOCATE( td_var%t_att(td_var%i_natt+il_natt), stat=il_status ) 5394 IF(il_status /= 0 )THEN 5395 5396 CALL logger_error( & 5397 & " VAR ADD ATT: not enough space to put attributes "//& 5398 & "in variable structure "//TRIM(td_var%c_name) ) 5399 5400 ENDIF 5401 5402 ! copy attribute in variable before 5403 td_var%t_att(1:td_var%i_natt)=att_copy(tl_att(:)) 5404 5405 ! clean 5406 CALL att_clean(tl_att(:)) 5407 DEALLOCATE(tl_att) 5408 5409 ENDIF 5410 ELSE 5411 ! no attribute in variable structure 5412 IF( ASSOCIATED(td_var%t_att) )THEN 5413 CALL att_clean(td_var%t_att(:)) 5414 DEALLOCATE(td_var%t_att) 5415 ENDIF 5416 ALLOCATE( td_var%t_att(td_var%i_natt+il_natt), stat=il_status ) 5417 IF(il_status /= 0 )THEN 5418 5419 CALL logger_error( & 5420 & " VAR ADD ATT: not enough space to put attributes "//& 5421 & "in variable structure "//TRIM(td_var%c_name) ) 5422 5423 ENDIF 5424 ENDIF 5425 5426 ALLOCATE( tl_att(il_natt) ) 5427 tl_att(:)=att_copy(td_att(:)) 5428 5429 ! check if attribute already in variable structure 4842 5430 DO ji=1,il_natt 4843 CALL var_add_att(td_var, td_att(ji)) 5431 il_ind=0 5432 il_ind=att_get_index( td_var%t_att(:), tl_att(ji)%c_name ) 5433 IF( il_ind /= 0 )THEN 5434 CALL logger_error( & 5435 & " VAR ADD ATT: attribute "//TRIM(tl_att(ji)%c_name)//& 5436 & ", already in variable "//TRIM(td_var%c_name) ) 5437 CALL att_clean(tl_att(ji)) 5438 ENDIF 4844 5439 ENDDO 5440 5441 ! add new attributes 5442 td_var%t_att(td_var%i_natt+1:td_var%i_natt+il_natt)=att_copy(tl_att(:)) 5443 5444 DEALLOCATE(tl_att) 5445 5446 DO ji=1,il_natt 5447 ! highlight some attribute 5448 IF( ASSOCIATED(td_var%t_att(td_var%i_natt+ji)%d_value) .OR. & 5449 & td_var%t_att(td_var%i_natt+ji)%c_value /= 'none' )THEN 5450 SELECT CASE(TRIM(td_var%t_att(td_var%i_natt+ji)%c_name)) 5451 5452 CASE("add_offset") 5453 td_var%d_ofs = td_var%t_att(td_var%i_natt+ji)%d_value(1) 5454 CASE("scale_factor") 5455 td_var%d_scf = td_var%t_att(td_var%i_natt+ji)%d_value(1) 5456 CASE("_FillValue") 5457 td_var%d_fill = td_var%t_att(td_var%i_natt+ji)%d_value(1) 5458 CASE("ew_overlap") 5459 td_var%i_ew = INT(td_var%t_att(td_var%i_natt+ji)%d_value(1),i4) 5460 CASE("standard_name") 5461 td_var%c_stdname = TRIM(td_var%t_att(td_var%i_natt+ji)%c_value) 5462 CASE("long_name") 5463 td_var%c_longname = TRIM(td_var%t_att(td_var%i_natt+ji)%c_value) 5464 CASE("units") 5465 td_var%c_units = TRIM(td_var%t_att(td_var%i_natt+ji)%c_value) 5466 CASE("grid_point") 5467 td_var%c_point = TRIM(td_var%t_att(td_var%i_natt+ji)%c_value) 5468 5469 END SELECT 5470 ENDIF 5471 ENDDO 5472 5473 ! update number of attribute 5474 td_var%i_natt=td_var%i_natt+il_natt 5475 4845 5476 4846 5477 END SUBROUTINE var__add_att_arr … … 4850 5481 ! 4851 5482 !> @author J.Paul 4852 !> - November, 2013- Initial Version 5483 !> @date November, 2013 - Initial Version 5484 !> @date June, 2015 5485 !> - use var__add_att_arr subroutine 4853 5486 ! 4854 5487 !> @param[inout] td_var variable structure … … 4862 5495 4863 5496 ! local variable 4864 INTEGER(i4) :: il_status 4865 INTEGER(i4) :: il_ind 4866 TYPE(TATT), DIMENSION(:), ALLOCATABLE :: tl_att 5497 TYPE(TATT), DIMENSION(1) :: tl_att 4867 5498 4868 5499 ! loop indices 4869 INTEGER(i4) :: ji4870 5500 !---------------------------------------------------------------- 4871 5501 4872 ! check if attribute already in variable structure 4873 il_ind=0 4874 IF( ASSOCIATED(td_var%t_att) )THEN 4875 il_ind=att_get_index( td_var%t_att(:), td_att%c_name ) 4876 ENDIF 4877 4878 IF( il_ind /= 0 )THEN 4879 4880 CALL logger_error( & 4881 & " VAR ADD ATT: attribute "//TRIM(td_att%c_name)//& 4882 & ", already in variable "//TRIM(td_var%c_name) ) 4883 4884 DO ji=1,td_var%i_natt 4885 CALL logger_debug( & 4886 & " VAR ADD ATT: in variable "//TRIM(td_var%t_att(ji)%c_name) ) 4887 ENDDO 4888 4889 ELSE 4890 4891 CALL logger_trace( & 4892 & " VAR ADD ATT: add attribute "//TRIM(td_att%c_name)//& 4893 & ", in variable "//TRIM(td_var%c_name) ) 4894 4895 IF( td_var%i_natt > 0 )THEN 4896 ! already other attribute in variable structure 4897 ALLOCATE( tl_att(td_var%i_natt), stat=il_status ) 4898 IF(il_status /= 0 )THEN 4899 4900 CALL logger_error( & 4901 & " VAR ADD ATT: not enough space to put attributes from "//& 4902 & TRIM(td_var%c_name)//" in temporary attribute structure") 4903 4904 ELSE 4905 4906 ! save temporary global attribute's variable structure 4907 tl_att(:)=att_copy(td_var%t_att(:)) 4908 4909 CALL att_clean(td_var%t_att(:)) 4910 DEALLOCATE( td_var%t_att ) 4911 ALLOCATE( td_var%t_att(td_var%i_natt+1), stat=il_status ) 4912 IF(il_status /= 0 )THEN 4913 4914 CALL logger_error( & 4915 & " VAR ADD ATT: not enough space to put attributes "//& 4916 & "in variable structure "//TRIM(td_var%c_name) ) 4917 4918 ENDIF 4919 4920 ! copy attribute in variable before 4921 td_var%t_att(1:td_var%i_natt)=att_copy(tl_att(:)) 4922 4923 ! clean 4924 CALL att_clean(tl_att(:)) 4925 DEALLOCATE(tl_att) 4926 4927 ENDIF 4928 ELSE 4929 ! no attribute in variable structure 4930 IF( ASSOCIATED(td_var%t_att) )THEN 4931 CALL att_clean(td_var%t_att(:)) 4932 DEALLOCATE(td_var%t_att) 4933 ENDIF 4934 ALLOCATE( td_var%t_att(td_var%i_natt+1), stat=il_status ) 4935 IF(il_status /= 0 )THEN 4936 4937 CALL logger_error( & 4938 & " VAR ADD ATT: not enough space to put attributes "//& 4939 & "in variable structure "//TRIM(td_var%c_name) ) 4940 4941 ENDIF 4942 ENDIF 4943 ! update number of attribute 4944 td_var%i_natt=td_var%i_natt+1 4945 4946 ! add new attribute 4947 td_var%t_att(td_var%i_natt)=att_copy(td_att) 4948 4949 !! add new attribute id 4950 !td_var%t_att(td_var%i_natt)%i_id=att_get_unit(td_var%t_att(:)) 4951 4952 ! highlight some attribute 4953 IF( ASSOCIATED(td_var%t_att(td_var%i_natt)%d_value) .OR. & 4954 & td_var%t_att(td_var%i_natt)%c_value /= "none" )THEN 4955 SELECT CASE(TRIM(td_var%t_att(td_var%i_natt)%c_name)) 4956 4957 CASE("add_offset") 4958 td_var%d_ofs = td_var%t_att(td_var%i_natt)%d_value(1) 4959 CASE("scale_factor") 4960 td_var%d_scf = td_var%t_att(td_var%i_natt)%d_value(1) 4961 CASE("_FillValue") 4962 td_var%d_fill = td_var%t_att(td_var%i_natt)%d_value(1) 4963 CASE("ew_overlap") 4964 td_var%i_ew = INT(td_var%t_att(td_var%i_natt)%d_value(1),i4) 4965 CASE("standard_name") 4966 td_var%c_stdname = TRIM(td_var%t_att(td_var%i_natt)%c_value) 4967 CASE("long_name") 4968 td_var%c_longname = TRIM(td_var%t_att(td_var%i_natt)%c_value) 4969 CASE("units") 4970 td_var%c_units = TRIM(td_var%t_att(td_var%i_natt)%c_value) 4971 CASE("grid_point") 4972 td_var%c_point = TRIM(td_var%t_att(td_var%i_natt)%c_value) 4973 4974 END SELECT 4975 ENDIF 4976 ENDIF 5502 ! copy structure in an array 5503 tl_att(1)=att_copy(td_att) 5504 5505 ! 5506 CALL var_add_att( td_var, tl_att(:) ) 4977 5507 4978 5508 END SUBROUTINE var__add_att_unit … … 4982 5512 ! 4983 5513 !> @author J.Paul 4984 !> - November, 2013- Initial Version 5514 !> @date November, 2013 - Initial Version 5515 !> @date February, 2015 5516 !> - define local attribute structure to avoid mistake 5517 !> with pointer 4985 5518 ! 4986 5519 !> @param[inout] td_var variable structure … … 4996 5529 INTEGER(i4) :: il_ind 4997 5530 5531 TYPE(TATT) :: tl_att 4998 5532 ! loop indices 4999 5533 !---------------------------------------------------------------- … … 5007 5541 IF( il_ind == 0 )THEN 5008 5542 5009 CALL logger_ warn( &5543 CALL logger_debug( & 5010 5544 & " VAR DEL ATT: no attribute "//TRIM(cd_name)//& 5011 5545 & ", in variable "//TRIM(td_var%c_name) ) … … 5013 5547 ELSE 5014 5548 5015 CALL var_del_att(td_var, td_var%t_att(il_ind)) 5549 tl_att=att_copy(td_var%t_att(il_ind)) 5550 CALL var_del_att(td_var, tl_att) 5016 5551 5017 5552 ENDIF … … 5023 5558 ! 5024 5559 !> @author J.Paul 5025 !> - November, 2013- Initial Version 5560 !> @date November, 2013- Initial Version 5561 !> @date February, 2015 5562 !> - delete highlight attribute too, when attribute 5563 !> is deleted 5026 5564 ! 5027 5565 !> @param[inout] td_var variable structure … … 5040 5578 5041 5579 ! loop indices 5042 !INTEGER(i4) :: ji5043 5580 !---------------------------------------------------------------- 5044 5581 … … 5051 5588 IF( il_ind == 0 )THEN 5052 5589 5053 CALL logger_ warn( &5590 CALL logger_debug( & 5054 5591 & " VAR DEL ATT: no attribute "//TRIM(td_att%c_name)//& 5055 5592 & ", in variable "//TRIM(td_var%c_name) ) … … 5103 5640 td_var%t_att(1:td_var%i_natt)=att_copy(tl_att(:)) 5104 5641 5105 !! change attribute id5106 !DO ji=1,td_var%i_natt5107 ! td_var%t_att(ji)%i_id=ji5108 !ENDDO5109 5110 5642 ! clean 5111 5643 CALL att_clean(tl_att(:)) … … 5113 5645 ENDIF 5114 5646 ENDIF 5647 5648 ! highlight attribute 5649 SELECT CASE( TRIM(td_att%c_name) ) 5650 5651 CASE("add_offset") 5652 td_var%d_ofs = 0._dp 5653 CASE("scale_factor") 5654 td_var%d_scf = 1._dp 5655 CASE("_FillValue") 5656 td_var%d_fill = 0._dp 5657 CASE("ew_overlap") 5658 td_var%i_ew = -1 5659 CASE("standard_name") 5660 td_var%c_stdname = '' 5661 CASE("long_name") 5662 td_var%c_longname = '' 5663 CASE("units") 5664 td_var%c_units = '' 5665 CASE("grid_point") 5666 td_var%c_point = '' 5667 5668 END SELECT 5669 5115 5670 ENDIF 5116 5671 … … 5121 5676 ! 5122 5677 !> @author J.Paul 5123 !> - November, 2013- Initial Version5678 !> @date November, 2013 - Initial Version 5124 5679 ! 5125 5680 !> @param[inout] td_var variable structure … … 5156 5711 ! 5157 5712 !> @author J.Paul 5158 !> - November, 2013- Initial Version5713 !> @date November, 2013 - Initial Version 5159 5714 ! 5160 5715 !> @param[inout] td_var variable structure … … 5195 5750 ! 5196 5751 !> @author J.Paul 5197 !> - November, 2013- Initial Version5752 !> @date November, 2013 - Initial Version 5198 5753 ! 5199 5754 !> @param[inout] td_var variable structure … … 5211 5766 !---------------------------------------------------------------- 5212 5767 5213 IF( td_var%i_ndim <= 4)THEN5768 IF( td_var%i_ndim <= ip_maxdim )THEN 5214 5769 5215 5770 ! check if dimension already used in variable structure … … 5227 5782 ELSE 5228 5783 5229 ! back to unorder dimension array 5230 CALL dim_unorder(td_var%t_dim(:)) 5784 ! back to disorder dimension array 5785 CALL dim_disorder(td_var%t_dim(:)) 5786 5231 5787 ! add new dimension 5232 5788 td_var%t_dim(td_var%i_ndim+1)=dim_copy(td_dim) … … 5253 5809 ! 5254 5810 !> @author J.Paul 5255 !> - November, 2013- Initial Version5811 !> @date November, 2013 - Initial Version 5256 5812 ! 5257 5813 !> @param[inout] td_var variable structure … … 5272 5828 !---------------------------------------------------------------- 5273 5829 5274 IF( td_var%i_ndim <= 4)THEN5830 IF( td_var%i_ndim <= ip_maxdim )THEN 5275 5831 5276 5832 CALL logger_trace( & … … 5317 5873 ! 5318 5874 !> @author J.Paul 5319 !> - November, 2013- Initial Version5875 !> @date November, 2013 - Initial Version 5320 5876 ! 5321 5877 !> @param[inout] td_var variable structure … … 5360 5916 !> 5361 5917 !> @author J.Paul 5362 !> - June, 2014- Initial Version5918 !> @date June, 2014 - Initial Version 5363 5919 ! 5364 5920 !> @param[in] td_var array of variables structure … … 5386 5942 !> 5387 5943 !> @author J.Paul 5388 !> - November, 2013- Initial Version5944 !> @date November, 2013 - Initial Version 5389 5945 ! 5390 5946 !> @param[in] td_var variable structure … … 5493 6049 !> 5494 6050 !> @author J.Paul 5495 !> - November, 2013- Initial Version6051 !> @date November, 2013 - Initial Version 5496 6052 !> 5497 6053 !> @param[inout] td_var variable structure … … 5631 6187 !> 5632 6188 !> @author J.Paul 5633 !> - November, 2013- Initial Version6189 !> @date November, 2013 - Initial Version 5634 6190 !> 5635 6191 !> @param[inout] td_var variable structure … … 5685 6241 !> 5686 6242 !> @author J.Paul 5687 !> - November, 2013- Initial Version6243 !> @date November, 2013 - Initial Version 5688 6244 ! 5689 6245 !> @param[inout] td_var variable structure … … 5761 6317 ! 5762 6318 !> @author J.Paul 5763 !> - November, 2013- Initial Version6319 !> @date November, 2013 - Initial Version 5764 6320 ! 5765 6321 !> @param[inout] td_var variabele structure … … 5837 6393 ! 5838 6394 !> @author J.Paul 5839 !> - November, 2013- Initial Version6395 !> @date November, 2013 - Initial Version 5840 6396 ! 5841 6397 !> @param[inout] td_var variabele structure … … 5913 6469 ! 5914 6470 !> @author J.Paul 5915 !> - November, 2013- Initial Version6471 !> @date November, 2013 - Initial Version 5916 6472 ! 5917 6473 !> @param[inout] td_var variabele structure … … 5987 6543 !> 5988 6544 !> @author J.Paul 5989 !> - November, 2013- Initial Version6545 !> @date November, 2013 - Initial Version 5990 6546 ! 5991 6547 !> @param[inout] td_var variable structure … … 6057 6613 !> 6058 6614 !> @author J.Paul 6059 !> - November, 2013- Initial Version6615 !> @date November, 2013 - Initial Version 6060 6616 !> 6061 6617 !> @param[inout] td_var variable structure … … 6080 6636 !> 6081 6637 !> @author J.Paul 6082 !> - September, 2014- Initial Version6638 !> @date September, 2014 - Initial Version 6083 6639 !> 6084 6640 !> @param[in] td_var array of variable structure … … 6145 6701 !> 6146 6702 !> @author J.Paul 6147 !> - November, 2013- Initial Version6703 !> @date November, 2013 - Initial Version 6148 6704 ! 6149 6705 !> @param[in] td_var array of variable structure … … 6200 6756 !> 6201 6757 !> @author J.Paul 6202 !> - November, 2013- Initial Version6758 !> @date November, 2013 - Initial Version 6203 6759 ! 6204 6760 !> @param[in] td_var array of variable structure … … 6239 6795 !> 6240 6796 !> @author J.Paul 6241 !> - November, 2013- Initial Version6797 !> @date November, 2013 - Initial Version 6242 6798 ! 6243 6799 !> @param[inout] td_var array of variable structure … … 6322 6878 !> 6323 6879 !> @author J.Paul 6324 !> - November, 2013- Initial Version 6880 !> @date November, 2013 - Initial Version 6881 !> @date June, 2015 6882 !> - new namelist format to get extra information (interpolation,...) 6325 6883 ! 6326 6884 !> @param[in] cd_file configuration file of variable … … 6357 6915 6358 6916 il_fileid=fct_getunit() 6359 CALL logger_trace("VAR DEF EXTRA: open "//TRIM(cd_file))6360 6917 OPEN( il_fileid, FILE=TRIM(cd_file), & 6361 6918 & FORM='FORMATTED', & … … 6366 6923 CALL fct_err(il_status) 6367 6924 IF( il_status /= 0 )THEN 6368 CALL logger_error("VAR DEF EXTRA: opening file "//TRIM(cd_file)) 6925 CALL logger_fatal("VAR DEF EXTRA: can not open file "//& 6926 & TRIM(cd_file)) 6369 6927 ENDIF 6370 6928 … … 6375 6933 DO WHILE( il_status == 0 ) 6376 6934 6377 ! search line donot beginning with comment character6935 ! search line not beginning with comment character 6378 6936 IF( SCAN( TRIM(fct_concat(cp_com(:))) ,cl_line(1:1)) == 0 )THEN 6379 6937 il_nvar=il_nvar+1 … … 6419 6977 tg_varextra(ji)%c_axis =TRIM(fct_split(cl_line,3)) 6420 6978 tg_varextra(ji)%c_point =TRIM(fct_split(cl_line,4)) 6421 tg_varextra(ji)%c_stdname =TRIM(fct_split(cl_line,5)) 6422 tg_varextra(ji)%c_longname=TRIM(fct_split(cl_line,6)) 6423 6424 cl_interp=TRIM(fct_split(cl_line,7)) 6979 6980 cl_interp='int='//TRIM(fct_split(cl_line,5)) 6425 6981 tg_varextra(ji)%c_interp(:) = & 6426 6982 & var__get_interp(TRIM(tg_varextra(ji)%c_name), cl_interp) 6427 6983 CALL logger_debug("VAR DEF EXTRA: "//& 6428 6984 & TRIM(tg_varextra(ji)%c_name)//& 6429 & " "//TRIM(cl_interp)) 6985 & " "//TRIM(tg_varextra(ji)%c_interp(1))) 6986 6987 tg_varextra(ji)%c_longname=TRIM(fct_split(cl_line,6)) 6988 tg_varextra(ji)%c_stdname =TRIM(fct_split(cl_line,7)) 6430 6989 ELSE 6431 6990 ji=ji-1 … … 6458 7017 !> @details 6459 7018 !> string character format must be : <br/> 6460 !> "varname:int erp; filter; extrap; > min; <max"<br/>7019 !> "varname:int=interp; flt=filter; ext=extrap; min=min; max=max"<br/> 6461 7020 !> you could specify only interpolation, filter or extrapolation method, 6462 7021 !> whatever the order. you could find more … … 6464 7023 !> \ref extrap module.<br/> 6465 7024 !> Examples: 6466 !> cn_varinfo='Bathymetry:2*hamming(2,3); > 10.' 6467 !> cn_varinfo='votemper:cubic; dist_weight; <40.' 7025 !> cn_varinfo='Bathymetry:flt=2*hamming(2,3); min=10.' 7026 !> cn_varinfo='votemper:int=cubic; ext=dist_weight; max=40.' 7027 !> 7028 !> 7029 !> @warning variable should be define in tg_varextra (ie in configuration 7030 !> file, to be able to add information from namelist 6468 7031 !> 6469 7032 !> @note If you do not specify a method which is required, default one is … … 6471 7034 !> 6472 7035 !> @author J.Paul 6473 !> - November, 2013- Initial Version 7036 !> @date November, 2013 - Initial Version 7037 !> @date July, 2015 7038 !> - get unit and unit factor (to change unit) 6474 7039 ! 6475 7040 !> @param[in] cd_varinfo variable information from namelist … … 6486 7051 CHARACTER(LEN=lc), DIMENSION(1) :: cl_extrap 6487 7052 CHARACTER(LEN=lc), DIMENSION(5) :: cl_filter 7053 CHARACTER(LEN=lc) :: cl_unt 6488 7054 6489 7055 INTEGER(i4) :: il_ind … … 6492 7058 REAL(dp) :: dl_min 6493 7059 REAL(dp) :: dl_max 7060 REAL(dp) :: dl_unf 6494 7061 6495 7062 TYPE(TVAR) , DIMENSION(:), ALLOCATABLE :: tl_varextra … … 6508 7075 dl_min=var__get_min(cl_name, cl_method) 6509 7076 dl_max=var__get_max(cl_name, cl_method) 7077 dl_unf=var__get_unf(cl_name, cl_method) 6510 7078 cl_interp(:)=var__get_interp(cl_name, cl_method) 6511 7079 cl_extrap(:)=var__get_extrap(cl_name, cl_method) 6512 7080 cl_filter(:)=var__get_filter(cl_name, cl_method) 7081 cl_unt=var__get_unt(cl_name, cl_method) 7082 6513 7083 6514 7084 il_ind=var_get_index(tg_varextra(:), TRIM(cl_name)) … … 6516 7086 IF( dl_min /= dp_fill ) tg_varextra(il_ind)%d_min=dl_min 6517 7087 IF( dl_max /= dp_fill ) tg_varextra(il_ind)%d_max=dl_max 7088 IF( dl_unf /= dp_fill ) tg_varextra(il_ind)%d_unf=dl_unf 7089 IF(cl_unt /='') tg_varextra(il_ind)%c_unt =cl_unt 6518 7090 IF(cl_interp(1)/='') tg_varextra(il_ind)%c_interp(:)=cl_interp(:) 6519 7091 IF(cl_extrap(1)/='') tg_varextra(il_ind)%c_extrap(:)=cl_extrap(:) … … 6551 7123 & cd_filter=cl_filter(:), & 6552 7124 & dd_min = dl_min, & 6553 & dd_max = dl_max ) 7125 & dd_max = dl_max, & 7126 & cd_unt = cl_unt, & 7127 & dd_unf = dl_unf ) 6554 7128 6555 7129 ENDIF 6556 7130 6557 7131 ji=ji+1 6558 CALL logger_ trace( "VAR CHG EXTRA: name "//&7132 CALL logger_debug( "VAR CHG EXTRA: name "//& 6559 7133 & TRIM(tg_varextra(il_ind)%c_name) ) 6560 CALL logger_ trace( "VAR CHG EXTRA: interp "//&7134 CALL logger_debug( "VAR CHG EXTRA: interp "//& 6561 7135 & TRIM(tg_varextra(il_ind)%c_interp(1)) ) 6562 CALL logger_ trace( "VAR CHG EXTRA: filter "//&7136 CALL logger_debug( "VAR CHG EXTRA: filter "//& 6563 7137 & TRIM(tg_varextra(il_ind)%c_filter(1)) ) 6564 CALL logger_ trace( "VAR CHG EXTRA: extrap "//&7138 CALL logger_debug( "VAR CHG EXTRA: extrap "//& 6565 7139 & TRIM(tg_varextra(il_ind)%c_extrap(1)) ) 6566 7140 IF( tg_varextra(il_ind)%d_min /= dp_fill )THEN 6567 CALL logger_ trace( "VAR CHG EXTRA: min value "//&7141 CALL logger_debug( "VAR CHG EXTRA: min value "//& 6568 7142 & TRIM(fct_str(tg_varextra(il_ind)%d_min)) ) 6569 7143 ENDIF 6570 7144 IF( tg_varextra(il_ind)%d_max /= dp_fill )THEN 6571 CALL logger_ trace( "VAR CHG EXTRA: max value "//&7145 CALL logger_debug( "VAR CHG EXTRA: max value "//& 6572 7146 & TRIM(fct_str(tg_varextra(il_ind)%d_max)) ) 7147 ENDIF 7148 IF( TRIM(tg_varextra(il_ind)%c_unt) /= '' )THEN 7149 CALL logger_debug( "VAR CHG EXTRA: new unit "//& 7150 & TRIM(tg_varextra(il_ind)%c_unt) ) 7151 ENDIF 7152 IF( tg_varextra(il_ind)%d_unf /= 1. )THEN 7153 CALL logger_debug( "VAR CHG EXTRA: new unit factor "//& 7154 & TRIM(fct_str(tg_varextra(il_ind)%d_unf)) ) 6573 7155 ENDIF 6574 7156 ENDDO … … 6593 7175 !> 6594 7176 !> @author J.Paul 6595 !> - November, 2013- Initial Version7177 !> @date November, 2013 - Initial Version 6596 7178 ! 6597 7179 !> @param[inout] td_var variable structure … … 6687 7269 !> 6688 7270 !> @author J.Paul 6689 !> - November, 2013- Initial Version7271 !> @date November, 2013 - Initial Version 6690 7272 !> 6691 7273 !> @param[inout] td_var variable structure … … 6808 7390 ENDIF 6809 7391 6810 CALL logger_trace("VAR GET EXTRA: name "//TRIM(td_var%c_name)) 6811 CALL logger_trace("VAR GET EXTRA: stdname "//TRIM(td_var%c_stdname)) 6812 CALL logger_trace("VAR GET EXTRA: longname "//TRIM(td_var%c_longname)) 6813 CALL logger_trace("VAR GET EXTRA: units "//TRIM(td_var%c_units)) 6814 CALL logger_trace("VAR GET EXTRA: point "//TRIM(td_var%c_point)) 6815 CALL logger_trace("VAR GET EXTRA: interp "//TRIM(td_var%c_interp(1))) 6816 CALL logger_trace("VAR GET EXTRA: filter "//TRIM(td_var%c_filter(1))) 6817 CALL logger_trace("VAR GET EXTRA: min value "//TRIM(fct_str(td_var%d_min))) 6818 CALL logger_trace("VAR GET EXTRA: max value "//TRIM(fct_str(td_var%d_max))) 7392 ! unt 7393 IF( TRIM(td_var%c_unt) == '' .AND. & 7394 & TRIM(tg_varextra(il_ind)%c_unt) /= '' )THEN 7395 td_var%c_unt=TRIM(tg_varextra(il_ind)%c_unt) 7396 ENDIF 7397 7398 ! units factor 7399 IF( td_var%d_unf == 1._dp .AND. & 7400 & tg_varextra(il_ind)%d_unf /= 1._dp )THEN 7401 td_var%d_unf=tg_varextra(il_ind)%d_unf 7402 ENDIF 7403 6819 7404 ENDIF 6820 7405 … … 6833 7418 !> 6834 7419 !> @details 6835 !> minimum value is assume to follow s ign '>'7420 !> minimum value is assume to follow string "min =" 6836 7421 !> 6837 7422 !> @author J.Paul 6838 !> - November, 2013- Initial Version 7423 !> @date November, 2013 - Initial Version 7424 !> @date June, 2015 7425 !> - change way to get information in namelist, 7426 !> value follows string "min =" 6839 7427 ! 6840 7428 !> @param[in] cd_name variable name … … 6867 7455 cl_tmp=fct_split(cd_varinfo,ji,';') 6868 7456 DO WHILE( TRIM(cl_tmp) /= '' ) 6869 il_ind= SCAN(TRIM(cl_tmp),'>')7457 il_ind=INDEX(TRIM(cl_tmp),'min') 6870 7458 IF( il_ind /= 0 )THEN 6871 cl_min= TRIM(ADJUSTL(cl_tmp(il_ind+1:)))7459 cl_min=fct_split(cl_tmp,2,'=') 6872 7460 EXIT 6873 7461 ENDIF … … 6877 7465 6878 7466 IF( TRIM(cl_min) /= '' )THEN 6879 IF( fct_is_ num(cl_min) )THEN7467 IF( fct_is_real(cl_min) )THEN 6880 7468 READ(cl_min,*) var__get_min 6881 7469 CALL logger_debug("VAR GET MIN: will use minimum value of "//& … … 6894 7482 !> 6895 7483 !> @details 6896 !> maximum value is assume to follow s ign '<'7484 !> maximum value is assume to follow string "max =" 6897 7485 !> 6898 7486 !> @author J.Paul 6899 !> - November, 2013- Initial Version 7487 !> @date November, 2013 - Initial Version 7488 !> @date June, 2015 7489 !> - change way to get information in namelist, 7490 !> value follows string "max =" 6900 7491 ! 6901 7492 !> @param[in] cd_name variable name … … 6928 7519 cl_tmp=fct_split(cd_varinfo,ji,';') 6929 7520 DO WHILE( TRIM(cl_tmp) /= '' ) 6930 il_ind= SCAN(TRIM(cl_tmp),'<')7521 il_ind=INDEX(TRIM(cl_tmp),'max') 6931 7522 IF( il_ind /= 0 )THEN 6932 cl_max= TRIM(ADJUSTL(cl_tmp(il_ind+1:)))7523 cl_max=fct_split(cl_tmp,2,'=') 6933 7524 EXIT 6934 7525 ENDIF … … 6938 7529 6939 7530 IF( TRIM(cl_max) /= '' )THEN 6940 IF( fct_is_ num(cl_max) )THEN7531 IF( fct_is_real(cl_max) )THEN 6941 7532 READ(cl_max,*) var__get_max 6942 7533 CALL logger_debug("VAR GET MAX: will use maximum value of "//& … … 6952 7543 !> @brief 6953 7544 !> This function check if variable information read in namelist contains 7545 !> units factor value and return it if true. 7546 !> 7547 !> @details 7548 !> units factor value is assume to follow string "unf =" 7549 !> 7550 !> @author J.Paul 7551 !> @date June, 2015 - Initial Version 7552 ! 7553 !> @param[in] cd_name variable name 7554 !> @param[in] cd_varinfo variable information read in namelist 7555 !> @return untis factor value to be used (FillValue if none) 7556 !------------------------------------------------------------------- 7557 FUNCTION var__get_unf( cd_name, cd_varinfo ) 7558 IMPLICIT NONE 7559 ! Argument 7560 CHARACTER(LEN=*), INTENT(IN ) :: cd_name 7561 CHARACTER(LEN=*), INTENT(IN ) :: cd_varinfo 7562 7563 ! function 7564 REAL(dp) :: var__get_unf 7565 7566 ! local variable 7567 CHARACTER(LEN=lc) :: cl_tmp 7568 CHARACTER(LEN=lc) :: cl_unf 7569 7570 INTEGER(i4) :: il_ind 7571 7572 REAL(dp) :: rl_unf 7573 7574 ! loop indices 7575 INTEGER(i4) :: ji 7576 !---------------------------------------------------------------- 7577 ! init 7578 cl_unf='' 7579 var__get_unf=dp_fill 7580 7581 ji=1 7582 cl_tmp=fct_split(cd_varinfo,ji,';') 7583 DO WHILE( TRIM(cl_tmp) /= '' ) 7584 il_ind=INDEX(TRIM(cl_tmp),'unf') 7585 IF( il_ind /= 0 )THEN 7586 cl_unf=fct_split(cl_tmp,2,'=') 7587 EXIT 7588 ENDIF 7589 ji=ji+1 7590 cl_tmp=fct_split(cd_varinfo,ji,';') 7591 ENDDO 7592 7593 IF( TRIM(cl_unf) /= '' )THEN 7594 rl_unf=math_compute(cl_unf) 7595 IF( rl_unf /= dp_fill )THEN 7596 var__get_unf = rl_unf 7597 CALL logger_debug("VAR GET UNITS FACTOR: will use units factor "//& 7598 & "value of "//TRIM(fct_str(var__get_unf))//" for variable "//& 7599 & TRIM(cd_name) ) 7600 ELSE 7601 CALL logger_error("VAR GET UNITS FACTOR: invalid units factor "//& 7602 & "value for variable "//TRIM(cd_name)//". check namelist." ) 7603 ENDIF 7604 ENDIF 7605 7606 END FUNCTION var__get_unf 7607 !------------------------------------------------------------------- 7608 !> @brief 7609 !> This function check if variable information read in namelist contains 6954 7610 !> interpolation method and return it if true. 6955 7611 !> 6956 7612 !> @details 6957 !> split namelist information, using ';' as separator. 7613 !> interpolation method is assume to follow string "int =" 7614 !> 6958 7615 !> compare method name with the list of interpolation method available (see 6959 7616 !> module global). 6960 7617 !> check if factor (*rhoi, /rhoj..) are present.<br/> 6961 7618 !> Example:<br/> 6962 !> - cubic/rhoi ;dist_weight6963 !> - bilin7619 !> - int=cubic/rhoi ; ext=dist_weight 7620 !> - int=bilin 6964 7621 !> see @ref interp module for more information. 6965 7622 !> 6966 7623 !> @author J.Paul 6967 !> - November, 2013- Initial Version 7624 !> @date November, 2013 - Initial Version 7625 !> @date June, 2015 7626 !> - change way to get information in namelist, 7627 !> value follows string "int =" 6968 7628 ! 6969 7629 !> @param[in] cd_name variable name … … 6982 7642 ! local variable 6983 7643 CHARACTER(LEN=lc) :: cl_tmp 7644 CHARACTER(LEN=lc) :: cl_int 6984 7645 CHARACTER(LEN=lc) :: cl_factor 6985 7646 … … 7000 7661 cl_tmp=fct_split(cd_varinfo,ji,';') 7001 7662 DO WHILE( TRIM(cl_tmp) /= '' ) 7663 il_ind=INDEX(TRIM(cl_tmp),'int') 7664 IF( il_ind /= 0 )THEN 7665 cl_int=fct_split(cl_tmp,2,'=') 7666 EXIT 7667 ENDIF 7668 ji=ji+1 7669 cl_tmp=fct_split(cd_varinfo,ji,';') 7670 ENDDO 7671 7672 IF( TRIM(cl_int) /= '' )THEN 7002 7673 DO jj=1,ip_ninterp 7003 il_ind= INDEX(fct_lower(cl_ tmp),TRIM(cp_interp_list(jj)))7674 il_ind= INDEX(fct_lower(cl_int),TRIM(cp_interp_list(jj))) 7004 7675 IF( il_ind /= 0 )THEN 7005 7676 … … 7009 7680 ! look for factor 7010 7681 IF( il_ind==1 )THEN 7011 cl_factor=cl_ tmp(il_len+1:)7682 cl_factor=cl_int(il_len+1:) 7012 7683 ELSE 7013 cl_factor=cl_ tmp(1:il_ind-1)7684 cl_factor=cl_int(1:il_ind-1) 7014 7685 ENDIF 7015 7686 il_mul=SCAN(TRIM(cl_factor),'*') … … 7052 7723 ENDIF 7053 7724 ENDDO 7054 IF( jj /= ip_ninterp + 1 ) EXIT 7055 ji=ji+1 7056 cl_tmp=fct_split(cd_varinfo,ji,';') 7057 ENDDO 7725 ENDIF 7058 7726 7059 7727 END FUNCTION var__get_interp … … 7064 7732 !> 7065 7733 !> @details 7066 !> split namelist information, using ';' as separator. 7734 !> extrapolation method is assume to follow string "ext =" 7735 !> 7067 7736 !> compare method name with the list of extrapolation method available (see 7068 7737 !> module global).<br/> 7069 7738 !> Example:<br/> 7070 !> - cubic ;dist_weight7071 !> - min_error7739 !> - int=cubic ; ext=dist_weight 7740 !> - ext=min_error 7072 7741 !> see @ref extrap module for more information. 7073 7742 !> 7074 7743 !> @author J.Paul 7075 !> - November, 2013- Initial Version 7744 !> @date November, 2013 - Initial Version 7745 !> @date June, 2015 7746 !> - change way to get information in namelist, 7747 !> value follows string "ext =" 7076 7748 ! 7077 7749 !> @param[in] cd_name variable name … … 7090 7762 ! local variable 7091 7763 CHARACTER(LEN=lc) :: cl_tmp 7764 CHARACTER(LEN=lc) :: cl_ext 7765 7766 INTEGER(i4) :: il_ind 7092 7767 7093 7768 ! loop indices … … 7101 7776 cl_tmp=fct_split(cd_varinfo,ji,';') 7102 7777 DO WHILE( TRIM(cl_tmp) /= '' ) 7778 il_ind=INDEX(TRIM(cl_tmp),'ext') 7779 IF( il_ind /= 0 )THEN 7780 cl_ext=fct_split(cl_tmp,2,'=') 7781 EXIT 7782 ENDIF 7783 ji=ji+1 7784 cl_tmp=fct_split(cd_varinfo,ji,';') 7785 ENDDO 7786 7787 IF( TRIM(cl_ext) /= '' )THEN 7103 7788 DO jj=1,ip_nextrap 7104 IF( TRIM(fct_lower(cl_ tmp)) == TRIM(cp_extrap_list(jj)) )THEN7789 IF( TRIM(fct_lower(cl_ext)) == TRIM(cp_extrap_list(jj)) )THEN 7105 7790 var__get_extrap(1)=TRIM(cp_extrap_list(jj)) 7106 7791 … … 7111 7796 ENDIF 7112 7797 ENDDO 7113 IF( jj /= ip_nextrap + 1 ) EXIT 7114 ji=ji+1 7115 cl_tmp=fct_split(cd_varinfo,ji,';') 7116 ENDDO 7798 ENDIF 7117 7799 7118 7800 … … 7124 7806 !> 7125 7807 !> @details 7126 !> split namelist information, using ';' as separator. 7808 !> filter method is assume to follow string "flt =" 7809 !> 7127 7810 !> compare method name with the list of filter method available (see 7128 7811 !> module global). 7129 !> look for the number of turn, using '*' separator, and method parameters inside7812 !> look for the number of run, using '*' separator, and method parameters inside 7130 7813 !> bracket.<br/> 7131 7814 !> Example:<br/> 7132 !> - cubic ;2*hamming(2,3)7133 !> - hann7815 !> - int=cubic ; flt=2*hamming(2,3) 7816 !> - flt=hann 7134 7817 !> see @ref filter module for more information. 7135 7818 !> 7136 7819 !> @author J.Paul 7137 !> - November, 2013- Initial Version 7138 ! 7820 !> @date November, 2013 - Initial Version 7821 !> @date June, 2015 7822 !> - change way to get information in namelist, 7823 !> value follows string "flt =" 7824 !> 7139 7825 !> @param[in] cd_name variable name 7140 7826 !> @param[in] cd_varinfo variable information read in namelist … … 7151 7837 ! local variable 7152 7838 CHARACTER(LEN=lc) :: cl_tmp 7839 CHARACTER(LEN=lc) :: cl_flt 7153 7840 INTEGER(i4) :: il_ind 7154 7841 … … 7163 7850 cl_tmp=fct_split(cd_varinfo,ji,';') 7164 7851 DO WHILE( TRIM(cl_tmp) /= '' ) 7852 il_ind=INDEX(TRIM(cl_tmp),'flt') 7853 IF( il_ind /= 0 )THEN 7854 cl_flt=fct_split(cl_tmp,2,'=') 7855 EXIT 7856 ENDIF 7857 ji=ji+1 7858 cl_tmp=fct_split(cd_varinfo,ji,';') 7859 ENDDO 7860 7861 IF( TRIM(cl_flt) /= '' )THEN 7165 7862 DO jj=1,ip_nfilter 7166 il_ind=INDEX(fct_lower(cl_ tmp),TRIM(cp_filter_list(jj)))7863 il_ind=INDEX(fct_lower(cl_flt),TRIM(cp_filter_list(jj))) 7167 7864 IF( il_ind /= 0 )THEN 7168 7865 var__get_filter(1)=TRIM(cp_filter_list(jj)) 7169 7866 7170 ! look for number of turn7171 il_ind=SCAN(fct_lower(cl_ tmp),'*')7867 ! look for number of run 7868 il_ind=SCAN(fct_lower(cl_flt),'*') 7172 7869 IF( il_ind /=0 )THEN 7173 IF( fct_is_num(cl_ tmp(1:il_ind-1)) )THEN7174 var__get_filter(2)=TRIM(cl_ tmp(1:il_ind-1))7175 ELSE IF( fct_is_num(cl_ tmp(il_ind+1:)) )THEN7176 var__get_filter(2)=TRIM(cl_ tmp(il_ind+1:))7870 IF( fct_is_num(cl_flt(1:il_ind-1)) )THEN 7871 var__get_filter(2)=TRIM(cl_flt(1:il_ind-1)) 7872 ELSE IF( fct_is_num(cl_flt(il_ind+1:)) )THEN 7873 var__get_filter(2)=TRIM(cl_flt(il_ind+1:)) 7177 7874 ELSE 7178 7875 var__get_filter(2)='1' … … 7183 7880 7184 7881 ! look for filter parameter 7185 il_ind=SCAN(fct_lower(cl_ tmp),'(')7882 il_ind=SCAN(fct_lower(cl_flt),'(') 7186 7883 IF( il_ind /=0 )THEN 7187 cl_ tmp=TRIM(cl_tmp(il_ind+1:))7188 il_ind=SCAN(fct_lower(cl_ tmp),')')7884 cl_flt=TRIM(cl_flt(il_ind+1:)) 7885 il_ind=SCAN(fct_lower(cl_flt),')') 7189 7886 IF( il_ind /=0 )THEN 7190 cl_ tmp=TRIM(cl_tmp(1:il_ind-1))7887 cl_flt=TRIM(cl_flt(1:il_ind-1)) 7191 7888 ! look for cut-off frequency 7192 var__get_filter(3)=fct_split(cl_ tmp,1,',')7889 var__get_filter(3)=fct_split(cl_flt,1,',') 7193 7890 ! look for halo size 7194 var__get_filter(4)=fct_split(cl_ tmp,2,',')7891 var__get_filter(4)=fct_split(cl_flt,2,',') 7195 7892 ! look for alpha parameter 7196 var__get_filter(5)=fct_split(cl_ tmp,3,',')7893 var__get_filter(5)=fct_split(cl_flt,3,',') 7197 7894 ELSE 7198 7895 CALL logger_error("VAR GET FILTER: variable "//& … … 7215 7912 ENDIF 7216 7913 ENDDO 7217 IF( jj /= ip_nfilter + 1 ) EXIT 7914 ENDIF 7915 7916 END FUNCTION var__get_filter 7917 !------------------------------------------------------------------- 7918 !> @brief 7919 !> This function check if variable information read in namelist contains 7920 !> unit and return it if true. 7921 !> 7922 !> @details 7923 !> unit is assume to follow string "unt =" 7924 !> 7925 !> @author J.Paul 7926 !> @date June, 2015 - Initial Version 7927 ! 7928 !> @param[in] cd_name variable name 7929 !> @param[in] cd_varinfo variable information read in namelist 7930 !> @return unit string character 7931 !------------------------------------------------------------------- 7932 FUNCTION var__get_unt( cd_name, cd_varinfo ) 7933 IMPLICIT NONE 7934 ! Argument 7935 CHARACTER(LEN=*), INTENT(IN ) :: cd_name 7936 CHARACTER(LEN=*), INTENT(IN ) :: cd_varinfo 7937 7938 ! function 7939 CHARACTER(LEN=lc) :: var__get_unt 7940 7941 ! local variable 7942 CHARACTER(LEN=lc) :: cl_tmp 7943 7944 INTEGER(i4) :: il_ind 7945 7946 ! loop indices 7947 INTEGER(i4) :: ji 7948 !---------------------------------------------------------------- 7949 7950 var__get_unt='' 7951 7952 ji=1 7953 cl_tmp=fct_split(cd_varinfo,ji,';') 7954 DO WHILE( TRIM(cl_tmp) /= '' ) 7955 il_ind=INDEX(TRIM(cl_tmp),'unt') 7956 IF( il_ind /= 0 )THEN 7957 var__get_unt=fct_split(cl_tmp,2,'=') 7958 EXIT 7959 ENDIF 7218 7960 ji=ji+1 7219 7961 cl_tmp=fct_split(cd_varinfo,ji,';') 7220 7962 ENDDO 7221 7963 7222 END FUNCTION var__get_filter 7964 IF( TRIM(var__get_unt) /= '' )THEN 7965 CALL logger_debug("VAR GET UNIT: will use units "//& 7966 & TRIM(var__get_unt)//" for variable "//& 7967 & TRIM(cd_name) ) 7968 ENDIF 7969 7970 END FUNCTION var__get_unt 7223 7971 !------------------------------------------------------------------- 7224 7972 !> @brief … … 7227 7975 !> 7228 7976 !> @author J.Paul 7229 !> - November, 2013- Initial Version7977 !> @date November, 2013 - Initial Version 7230 7978 ! 7231 7979 !> @param[in] td_var array of variable structure … … 7285 8033 !> 7286 8034 !> @author J.Paul 7287 !> - November, 2013- Initial Version8035 !> @date November, 2013 - Initial Version 7288 8036 ! 7289 8037 !> @param[inout] td_var variable structure … … 7321 8069 !------------------------------------------------------------------- 7322 8070 !> @brief 8071 !> This subroutine replace unit name of the variable, 8072 !> and apply unit factor to the value of this variable. 8073 !> 8074 !> @details 8075 !> new unit name (unt) and unit factor (unf) are read from the namelist. 8076 !> 8077 !> @note the variable value should be already read. 8078 !> 8079 !> @author J.Paul 8080 !> @date June, 2015 - Initial Version 8081 ! 8082 !> @param[inout] td_var variable structure 8083 !------------------------------------------------------------------- 8084 SUBROUTINE var_chg_unit( td_var ) 8085 IMPLICIT NONE 8086 ! Argument 8087 TYPE(TVAR), INTENT(INOUT) :: td_var 8088 8089 ! local variable 8090 TYPE(TATT) :: tl_att 8091 8092 ! loop indices 8093 !---------------------------------------------------------------- 8094 8095 IF( ASSOCIATED(td_var%d_value) )THEN 8096 !- change value 8097 IF( td_var%d_unf /= 1._dp )THEN 8098 WHERE( td_var%d_value(:,:,:,:) /= td_var%d_fill ) 8099 td_var%d_value(:,:,:,:)=td_var%d_value(:,:,:,:)*td_var%d_unf 8100 END WHERE 8101 8102 !- change scale factor and offset to avoid mistake 8103 tl_att=att_init('scale_factor',1) 8104 CALL var_move_att(td_var, tl_att) 8105 8106 tl_att=att_init('add_offset',0) 8107 CALL var_move_att(td_var, tl_att) 8108 ENDIF 8109 8110 !- change unit name 8111 IF( TRIM(td_var%c_unt) /= TRIM(td_var%c_units) .AND. & 8112 & TRIM(td_var%c_unt) /= '' )THEN 8113 tl_att=att_init('units',TRIM(td_var%c_unt)) 8114 CALL var_move_att(td_var,tl_att) 8115 ENDIF 8116 8117 ENDIF 8118 8119 END SUBROUTINE var_chg_unit 8120 !------------------------------------------------------------------- 8121 !> @brief 7323 8122 !> This subroutine check variable dimension expected, as defined in 7324 8123 !> file 'variable.cfg'. … … 7329 8128 !> 7330 8129 !> @author J.Paul 7331 !> - November, 2013- Initial Version8130 !> @date November, 2013 - Initial Version 7332 8131 ! 7333 8132 !> @param[inout] td_var variable structure … … 7414 8213 !> 7415 8214 !> @author J.Paul 7416 !> - August, 2014- Initial Version 8215 !> @date August, 2014 - Initial Version 8216 !> @date July 2015 8217 !> - do not use dim_disorder anymore 7417 8218 ! 7418 8219 !> @param[inout] td_var variable structure … … 7438 8239 IF( PRESENT(cd_dimorder) ) cl_dimorder=TRIM(ADJUSTL(cd_dimorder)) 7439 8240 8241 CALL logger_debug("VAR REORDER: work on "//TRIM(td_var%c_name)//& 8242 & " new dimension order "//TRIM(cl_dimorder)) 8243 7440 8244 tl_dim(:)=dim_copy(td_var%t_dim(:)) 7441 8245 7442 CALL dim_unorder(tl_dim(:))7443 8246 CALL dim_reorder(tl_dim(:),TRIM(cl_dimorder)) 7444 8247 … … 7467 8270 !> 7468 8271 !> @author J.Paul 7469 !> - September, 2014- Initial Version8272 !> @date September, 2014 - Initial Version 7470 8273 ! 7471 8274 !> @param[in] td_var array of variable structure … … 7492 8295 !> 7493 8296 !> @author J.Paul 7494 !> - November, 2014- Initial Version8297 !> @date November, 2014 - Initial Version 7495 8298 ! 7496 8299 !> @param[in] td_var time variable structure -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/src/vgrid.f90
r5037 r6487 70 70 !> @date Spetember, 2014 71 71 !> - add header 72 !> @date June, 2015 - update subroutine with NEMO 3.6 72 73 !> 73 74 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 118 119 !> 119 120 !> @author G. Madec 120 !> - 03,08- G. Madec:F90: Free form and module121 !> @date Marsh,2008 - F90: Free form and module 121 122 ! 122 123 !> @note Reference : Marti, Madec & Delecluse, 1992, JGR, 97, No8, 12,763-12,766. … … 139 140 !------------------------------------------------------------------- 140 141 SUBROUTINE vgrid_zgr_z( dd_gdepw, dd_gdept, dd_e3w, dd_e3t, & 142 & dd_e3w_1d, dd_e3t_1d, & 141 143 & dd_ppkth, dd_ppkth2, dd_ppacr, dd_ppacr2, & 142 144 & dd_ppdzmin, dd_pphmax, dd_pp_to_be_computed, & … … 148 150 REAL(dp), DIMENSION(:), INTENT(INOUT) :: dd_e3w 149 151 REAL(dp), DIMENSION(:), INTENT(INOUT) :: dd_e3t 152 REAL(dp), DIMENSION(:), INTENT(INOUT) :: dd_e3w_1d 153 REAL(dp), DIMENSION(:), INTENT(INOUT) :: dd_e3t_1d 150 154 151 155 REAL(dp) , INTENT(IN ) :: dd_ppkth … … 226 230 DO jk = 1, il_jpk 227 231 dl_zw = REAL(jk,dp) 228 dl_zt = REAL(jk,dp) + 0.5 232 dl_zt = REAL(jk,dp) + 0.5_dp 229 233 dd_gdepw(jk) = ( dl_zw - 1.0 ) * dl_za1 230 234 dd_gdept(jk) = ( dl_zt - 1.0 ) * dl_za1 … … 237 241 DO jk = 1, il_jpk 238 242 dl_zw = REAL( jk,dp) 239 dl_zt = REAL( jk,dp) + 0.5 243 dl_zt = REAL( jk,dp) + 0.5_dp 240 244 dd_gdepw(jk) = ( dl_zsur + dl_za0 * dl_zw + & 241 245 & dl_za1 * dl_zacr * LOG( COSH( (dl_zw-dl_zkth)/dl_zacr ) ) + & … … 255 259 ENDIF 256 260 261 ! need to be like this to compute the pressure gradient with ISF. 262 ! If not, level beneath the ISF are not aligned (sum(e3t) /= depth) 263 ! define e3t_0 and e3w_0 as the differences between gdept and gdepw respectively 264 DO jk = 1, il_jpk-1 265 dd_e3t_1d(jk) = dd_gdepw(jk+1)-dd_gdepw(jk) 266 END DO 267 dd_e3t_1d(il_jpk) = dd_e3t_1d(il_jpk-1) ! we don't care because this level is masked in NEMO 268 269 DO jk = 2, il_jpk 270 dd_e3w_1d(jk) = dd_gdept(jk) - dd_gdept(jk-1) 271 END DO 272 dd_e3w_1d(1 ) = 2._dp * (dd_gdept(1) - dd_gdepw(1)) 273 257 274 ! Control and print 258 275 ! ================== … … 260 277 DO jk = 1, il_jpk 261 278 IF( dd_e3w(jk) <= 0. .OR. dd_e3t(jk) <= 0. )then 262 CALL logger_debug("VGRID ZGR Z: e3w or e3t =<0 ")279 CALL logger_debug("VGRID ZGR Z: e3w or e3t <= 0 ") 263 280 ENDIF 281 282 IF( dd_e3w_1d(jk) <= 0. .OR. dd_e3t_1d(jk) <= 0. )then 283 CALL logger_debug("VGRID ZGR Z: e3w_1d or e3t_1d <= 0 ") 284 ENDIF 264 285 265 286 IF( dd_gdepw(jk) < 0. .OR. dd_gdept(jk) < 0. )then … … 269 290 270 291 END SUBROUTINE vgrid_zgr_z 292 !------------------------------------------------------------------- 293 !------------------------------------------------------------------- 294 SUBROUTINE vgrid_zgr_bat( dd_bathy, dd_gdepw, dd_hmin, dd_fill ) 295 IMPLICIT NONE 296 ! Argument 297 REAL(dp), DIMENSION(:,:), INTENT(INOUT) :: dd_bathy 298 REAL(dp), DIMENSION(:) , INTENT(IN ) :: dd_gdepw 299 REAL(dp) , INTENT(IN ) :: dd_hmin 300 REAL(dp) , INTENT(IN ), OPTIONAL :: dd_fill 301 302 ! local 303 INTEGER(i4) :: il_jpk 304 305 REAL(dp) :: dl_hmin 306 REAL(dp) :: dl_fill 307 308 ! loop indices 309 INTEGER(i4) :: jk 310 !---------------------------------------------------------------- 311 il_jpk = SIZE(dd_gdepw(:)) 312 313 dl_fill=0._dp 314 IF( PRESENT(dd_fill) ) dl_fill=dd_fill 315 316 IF( dd_hmin < 0._dp ) THEN 317 jk = - INT( dd_hmin ) ! from a nb of level 318 ELSE 319 jk = MINLOC( dd_gdepw, mask = dd_gdepw > dd_hmin, dim = 1 ) ! from a depth 320 ENDIF 321 322 dl_hmin = dd_gdepw(jk+1) ! minimum depth = ik+1 w-levels 323 WHERE( dd_bathy(:,:) <= 0._wp .OR. dd_bathy(:,:) == dl_fill ) 324 dd_bathy(:,:) = dl_fill ! min=0 over the lands 325 ELSE WHERE 326 dd_bathy(:,:) = MAX( dl_hmin , dd_bathy(:,:) ) ! min=dl_hmin over the oceans 327 END WHERE 328 WRITE(*,*) 'Minimum ocean depth: ', dl_hmin, ' minimum number of ocean levels : ', jk 329 330 END SUBROUTINE vgrid_zgr_bat 271 331 !------------------------------------------------------------------- 272 332 !> @brief This subroutine set the depth and vertical scale factor in partial step … … 313 373 ! 314 374 !> @author A. Bozec, G. Madec 315 !> - 02-09 (A. Bozec, G. Madec) F90: Free form and module 316 !> - 02-09 (A. de Miranda) rigid-lid + islands 375 !> @date February, 2009 - F90: Free form and module 376 !> @date February, 2009 377 !> - A. de Miranda : rigid-lid + islands 317 378 !> 318 379 !> @note Reference : Pacanowsky & Gnanadesikan 1997, Mon. Wea. Rev., 126, 3248-3270. … … 327 388 !------------------------------------------------------------------- 328 389 SUBROUTINE vgrid_zgr_zps( id_mbathy, dd_bathy, id_jpkmax, & 329 & dd_gdepw, dd_e3t, & 330 & dd_e3zps_min, dd_e3zps_rat ) 390 & dd_gdepw, dd_e3t, & 391 & dd_e3zps_min, dd_e3zps_rat, & 392 & dd_fill ) 331 393 IMPLICIT NONE 332 394 ! Argument … … 336 398 REAL(dp) , DIMENSION(:) , INTENT(IN ) :: dd_gdepw 337 399 REAL(dp) , DIMENSION(:) , INTENT(IN ) :: dd_e3t 338 REAL(dp) :: dd_e3zps_min 339 REAL(dp) :: dd_e3zps_rat 400 REAL(dp) , INTENT(IN ) :: dd_e3zps_min 401 REAL(dp) , INTENT(IN ) :: dd_e3zps_rat 402 REAL(dp) , INTENT(IN ), OPTIONAL :: dd_fill 340 403 341 404 ! local variable 342 405 REAL(dp) :: dl_zmax ! Maximum depth 343 REAL(dp) :: dl_zmin ! Minimum depth406 !REAL(dp) :: dl_zmin ! Minimum depth 344 407 REAL(dp) :: dl_zdepth ! Ajusted ocean depth to avoid too small e3t 408 REAL(dp) :: dl_fill 345 409 346 410 INTEGER(i4) :: il_jpk … … 359 423 il_jpjglo=SIZE(id_mbathy(:,:),DIM=2) 360 424 425 dl_fill=0._dp 426 IF( PRESENT(dd_fill) ) dl_fill=dd_fill 427 361 428 ! Initialization of constant 362 dl_zmax = dd_gdepw(il_jpk) + dd_e3t(il_jpk) 363 dl_zmin = dd_gdepw(4) 429 dl_zmax = dd_gdepw(il_jpk) + dd_e3t(il_jpk) ! maximum depth (i.e. the last ocean level thickness <= 2*e3t_1d(jpkm1) ) 430 431 ! bounded value of bathy (min already set at the end of zgr_bat) 432 WHERE( dd_bathy(:,:) /= dl_fill ) 433 dd_bathy(:,:) = MIN( dl_zmax , dd_bathy(:,:) ) 434 END WHERE 364 435 365 436 ! bathymetry in level (from bathy_meter) … … 372 443 DO jj = 1, il_jpjglo 373 444 DO ji= 1, il_jpiglo 374 IF( dd_bathy(ji,jj) <= 0. ) id_mbathy(ji,jj) = INT(dd_bathy(ji,jj),i4) 375 END DO 376 END DO 377 378 ! bounded value of bathy 379 ! minimum depth == 3 levels 380 ! maximum depth == gdepw(jpk)+e3t(jpk) 381 ! i.e. the last ocean level thickness cannot exceed e3t(jpkm1)+e3t(jpk) 382 DO jj = 1, il_jpjglo 383 DO ji= 1, il_jpiglo 384 IF( dd_bathy(ji,jj) <= 0. ) THEN 385 dd_bathy(ji,jj) = 0.e0 386 ELSE 387 dd_bathy(ji,jj) = MAX( dd_bathy(ji,jj), dl_zmin ) 388 dd_bathy(ji,jj) = MIN( dd_bathy(ji,jj), dl_zmax ) 445 IF( dd_bathy(ji,jj) <= 0._dp )THEN 446 id_mbathy(ji,jj) = INT(dd_bathy(ji,jj),i4) 447 ELSEIF( dd_bathy(ji,jj) == dl_fill )THEN 448 id_mbathy(ji,jj) = 0_i4 389 449 ENDIF 390 450 END DO … … 401 461 DO jj = 1, il_jpjglo 402 462 DO ji = 1, il_jpiglo 403 IF( 0. < dd_bathy(ji,jj) .AND. dd_bathy(ji,jj) <= dl_zdepth ) id_mbathy(ji,jj) = jk-1 463 IF( dd_bathy(ji,jj) /= dl_fill )THEN 464 IF( 0. < dd_bathy(ji,jj) .AND. & 465 & dd_bathy(ji,jj) <= dl_zdepth ) id_mbathy(ji,jj) = jk-1 466 ENDIF 404 467 END DO 405 468 END DO … … 434 497 435 498 !> @author G.Madec 436 !> - 03-08Original code499 !> @date Marsh, 2008 - Original code 437 500 ! 438 501 !> @param[in] id_mbathy … … 543 606 !> 544 607 !> @author J.Paul 545 !> - November, 2013- Initial Version608 !> @date November, 2013 - Initial Version 546 609 ! 547 610 !> @param[in] td_bathy Bathymetry file structure … … 567 630 REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_e3w 568 631 REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_e3t 632 REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_e3w_1d 633 REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_e3t_1d 569 634 570 635 INTEGER(i4) :: il_status … … 710 775 ALLOCATE( dl_gdepw(in_nlevel), dl_gdept(in_nlevel) ) 711 776 ALLOCATE( dl_e3w(in_nlevel), dl_e3t(in_nlevel) ) 777 ALLOCATE( dl_e3w_1d(in_nlevel), dl_e3t_1d(in_nlevel) ) 712 778 CALL vgrid_zgr_z( dl_gdepw(:), dl_gdept(:), dl_e3w(:), dl_e3t(:), & 779 & dl_e3w_1d, dl_e3t_1d, & 713 780 & dn_ppkth, dn_ppkth2, dn_ppacr, dn_ppacr2, & 714 781 & dn_ppdzmin, dn_pphmax, dn_pp_to_be_computed, & -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/templates/create_bathy.nam
r5037 r6487 19 19 20 20 &namvar 21 cn_varfile= 21 22 cn_varinfo= 22 cn_varfile=23 23 / 24 24 -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/templates/create_boundary.nam
r5037 r6487 60 60 cn_west = 61 61 ln_oneseg= 62 in_extrap=63 62 / 64 63 65 64 &namout 66 65 cn_fileout="boundary_out.nc" 66 dn_dayofs= 67 ln_extrap= 67 68 / -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/TOOLS/SIREN/templates/create_restart.nam
r5037 r6487 12 12 cn_coord0= 13 13 in_perio0= 14 / 15 16 &namfin 17 cn_coord1= 18 cn_bathy1= 19 in_perio1= 14 20 / 15 21 … … 34 40 / 35 41 36 &namfin37 cn_coord1=38 cn_bathy1=39 in_perio1=40 in_extrap=41 /42 43 42 &namvar 44 43 cn_varinfo= … … 53 52 &namout 54 53 cn_fileout="restart_out.nc" 54 ln_extrap= 55 in_nipro= 56 in_njproc= 57 in_nproc= 58 cn_type= 55 59 /
Note: See TracChangeset
for help on using the changeset viewer.