Changeset 1991 for vendors/IOIPSL/current/src/histcom.f90
- Timestamp:
- 2010-07-08T15:39:26+02:00 (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
vendors/IOIPSL/current/src/histcom.f90
r1895 r1991 1 1 MODULE histcom 2 2 !- 3 !$Id: histcom.f90 740 2009-09-17 08:26:28Z bellier $3 !$Id: histcom.f90 1028 2010-05-20 15:17:30Z bellier $ 4 4 !- 5 5 ! This software is governed by the CeCILL license … … 35 35 !- to describe the grid, just two vectors. 36 36 !--------------------------------------------------------------------- 37 !- 38 INTERFACE histbeg 39 MODULE PROCEDURE histb_reg1d,histb_reg2d,histb_irreg 40 END INTERFACE 41 !- 42 INTERFACE histhori 43 MODULE PROCEDURE histh_reg1d,histh_reg2d,histh_irreg 44 END INTERFACE 45 !- 37 46 INTERFACE histwrite 38 47 !--------------------------------------------------------------------- … … 46 55 !- 47 56 !- INPUT 48 !- pfileid: The ID of the file on which this variable is to be,57 !- idf : The ID of the file on which this variable is to be, 49 58 !- written. The variable should have been defined in 50 59 !- this file before. … … 63 72 END INTERFACE 64 73 !- 65 INTERFACE histbeg66 MODULE PROCEDURE histbeg_totreg,histbeg_regular,histbeg_irregular67 END INTERFACE68 !-69 INTERFACE histhori70 MODULE PROCEDURE histhori_regular,histhori_irregular71 END INTERFACE72 !-73 74 ! Fixed parameter 74 75 !- … … 76 77 & nb_hax_max=5,nb_zax_max=10,nbopp_max=10 77 78 REAL,PARAMETER :: missing_val=nf90_fill_real 78 !- 79 INTEGER :: bufftmp_max(nb_files_max) = 1 80 !- 81 ! Time variables 82 !- 83 INTEGER,SAVE :: itau0(nb_files_max)=0 84 REAL,DIMENSION(nb_files_max),SAVE ::date0,deltat 85 !- 86 ! Counter of elements 87 !- 88 INTEGER,SAVE :: nb_files=0 89 INTEGER,DIMENSION(nb_files_max),SAVE :: nb_var=0,nb_tax=0 90 !- 91 ! DOMAIN IDs for files 92 !- 93 INTEGER,DIMENSION(nb_files_max),SAVE :: dom_id_svg=-1 94 !- 95 ! NETCDF IDs for files and axes 96 !- 97 INTEGER,DIMENSION(nb_files_max),SAVE :: ncdf_ids,xid,yid,tid 98 !- 99 ! General definitions in the NETCDF file 100 !- 101 INTEGER,DIMENSION(nb_files_max,2),SAVE :: & 102 & full_size=0,slab_ori,slab_sz 103 !- 104 ! The horizontal axes 105 !- 106 INTEGER,SAVE :: nb_hax(nb_files_max)=0 107 CHARACTER(LEN=25),SAVE :: hax_name(nb_files_max,nb_hax_max,2) 108 !- 109 ! The vertical axes 110 !- 111 INTEGER,SAVE :: nb_zax(nb_files_max)=0 112 INTEGER,DIMENSION(nb_files_max,nb_zax_max),SAVE :: & 113 & zax_size,zax_ids 114 CHARACTER(LEN=20),SAVE :: zax_name(nb_files_max,nb_zax_max) 115 !- 116 ! Informations on each variable 117 !- 118 INTEGER,DIMENSION(nb_files_max,nb_var_max),SAVE :: & 119 & nbopp 120 CHARACTER(LEN=20),DIMENSION(nb_files_max,nb_var_max),SAVE :: & 121 & name,unit_name 122 CHARACTER(LEN=80),DIMENSION(nb_files_max,nb_var_max),SAVE :: & 123 & title,fullop 124 CHARACTER(LEN=7),SAVE :: topp(nb_files_max,nb_var_max) 125 CHARACTER(LEN=7),SAVE :: sopps(nb_files_max,nb_var_max,nbopp_max) 126 REAL,SAVE :: scal(nb_files_max,nb_var_max,nbopp_max) 127 !- Sizes of the associated grid and zommed area 128 INTEGER,DIMENSION(nb_files_max,nb_var_max,3),SAVE :: & 129 & scsize,zorig,zsize 130 !- Sizes for the data as it goes through the various math operations 131 INTEGER,SAVE :: datasz_in(nb_files_max,nb_var_max,3) = -1 132 INTEGER,SAVE :: datasz_max(nb_files_max,nb_var_max) = -1 133 !- 134 INTEGER,DIMENSION(nb_files_max,nb_var_max),SAVE :: & 135 & var_haxid,var_zaxid,var_axid,ncvar_ids 136 !- 137 REAL,DIMENSION(nb_files_max,nb_var_max,2),SAVE :: hist_minmax 138 LOGICAL,DIMENSION(nb_files_max,nb_var_max),SAVE :: & 139 & hist_calc_rng=.FALSE.,hist_wrt_rng=.FALSE. 140 !- 141 REAL,DIMENSION(nb_files_max,nb_var_max),SAVE :: & 142 & freq_opp,freq_wrt 143 INTEGER,DIMENSION(nb_files_max,nb_var_max),SAVE :: & 144 & last_opp,last_wrt,last_opp_chk,last_wrt_chk,nb_opp,nb_wrt,point 145 !- 146 ! Book keeping for the buffers 147 !- 148 INTEGER,SAVE :: buff_pos=0 149 REAL,ALLOCATABLE,DIMENSION(:),SAVE :: buffer 150 LOGICAL,DIMENSION(nb_files_max),SAVE :: zoom=.FALSE.,regular=.TRUE. 151 !- 152 ! Book keeping of the axes 153 !- 154 INTEGER,DIMENSION(nb_files_max,nb_var_max),SAVE :: & 155 & tdimid,tax_last 156 CHARACTER(LEN=40),DIMENSION(nb_files_max,nb_var_max),SAVE :: & 157 & tax_name 79 INTEGER,PARAMETER,PUBLIC :: & 80 & hist_r4=nf90_real4, hist_r8=nf90_real8 81 !- 82 ! Variable derived type 83 !- 84 TYPE T_D_V 85 INTEGER :: ncvid 86 INTEGER :: nbopp 87 CHARACTER(LEN=20) :: v_name,unit_name 88 CHARACTER(LEN=256) :: title,std_name 89 CHARACTER(LEN=80) :: fullop 90 CHARACTER(LEN=7) :: topp 91 CHARACTER(LEN=7),DIMENSION(nbopp_max) :: sopp 92 REAL,DIMENSION(nbopp_max) :: scal 93 !-External type (for R4/R8) 94 INTEGER :: v_typ 95 !-Sizes of the associated grid and zommed area 96 INTEGER,DIMENSION(3) :: scsize,zorig,zsize 97 !-Sizes for the data as it goes through the various math operations 98 INTEGER,DIMENSION(3) :: datasz_in = -1 99 INTEGER :: datasz_max = -1 100 !- 101 INTEGER :: h_axid,z_axid,t_axid 102 !- 103 REAL,DIMENSION(2) :: hist_minmax 104 LOGICAL :: hist_calc_rng=.FALSE.,hist_wrt_rng=.FALSE. 105 !-Book keeping of the axes 106 INTEGER :: tdimid,tbndid=-1,tax_last 107 LOGICAL :: l_bnd 108 CHARACTER(LEN=40) :: tax_name 109 !- 110 REAL :: freq_opp,freq_wrt 111 INTEGER :: & 112 & last_opp,last_wrt,last_opp_chk,last_wrt_chk,nb_opp,nb_wrt 113 !- For future optimization 114 REAL,POINTER,DIMENSION(:) :: t_bf 115 !# REAL,ALLOCATABLE,DIMENSION(:) :: V_1_D 116 !# REAL,ALLOCATABLE,DIMENSION(:,:) :: V_2_D 117 !# REAL,ALLOCATABLE,DIMENSION(:,:,:) :: V_3_D 118 END TYPE T_D_V 119 !- 120 ! File derived type 121 !- 122 TYPE :: T_D_F 123 !-NETCDF IDs for file 124 INTEGER :: ncfid=-1 125 !-Time variables 126 INTEGER :: itau0=0 127 REAL :: date0,deltat 128 !-Counter of elements (variables, time-horizontal-vertical axis 129 INTEGER :: n_var=0,n_tax=0,n_hax=0,n_zax=0 130 !-NETCDF dimension IDs for time-[time_bounds]-longitude-latitude 131 INTEGER :: tid,bid,xid,yid 132 !-General definitions in the NETCDF file 133 INTEGER,DIMENSION(2) :: full_size=0,slab_ori,slab_siz 134 !-The horizontal axes 135 CHARACTER(LEN=25),DIMENSION(nb_hax_max,2) :: hax_name 136 !-The vertical axes 137 INTEGER,DIMENSION(nb_zax_max) :: zax_size,zax_ids 138 CHARACTER(LEN=20),DIMENSION(nb_zax_max) :: zax_name 139 !- 140 LOGICAL :: regular=.TRUE. 141 !-DOMAIN ID 142 INTEGER :: dom_id_svg=-1 143 !- 144 TYPE(T_D_V),DIMENSION(nb_var_max) :: W_V 145 END TYPE T_D_F 146 !- 147 TYPE(T_D_F),DIMENSION(nb_files_max),SAVE :: W_F 158 148 !- 159 149 ! A list of functions which require special action … … 161 151 ! but they are well located here) 162 152 !- 163 CHARACTER(LEN=120),SAVE :: & 164 & indchfun = 'scatter, fill, gather, coll', & 165 & fuchnbout = 'scatter, fill' 153 CHARACTER(LEN=30),SAVE :: fuchnbout = 'scatter, fill' 166 154 !- Some configurable variables with locks 167 155 CHARACTER(LEN=80),SAVE :: model_name='An IPSL model' … … 172 160 !=== 173 161 !- 174 SUBROUTINE histbeg_totreg & 175 & (pfilename,pim,plon,pjm,plat, & 176 & par_orix,par_szx,par_oriy,par_szy, & 177 & pitau0,pdate0,pdeltat,phoriid,pfileid,domain_id) 178 !--------------------------------------------------------------------- 179 !- This is just an interface for histbeg_regular in case when 180 !- the user provides plon and plat as vectors. 181 !- Obviously this can only be used for very regular grids. 182 !- 183 !- INPUT 184 !- 185 !- pfilename : Name of the netcdf file to be created 186 !- pim : Size of arrays in longitude direction 187 !- plon : Coordinates of points in longitude 188 !- pjm : Size of arrays in latitude direction 189 !- plat : Coordinates of points in latitude 190 !- 191 !- The next 4 arguments allow to define a horizontal zoom 192 !- for this file. It is assumed that all variables to come 193 !- have the same index space. This can not be assumed for 194 !- the z axis and thus we define the zoom in histdef. 195 !- 196 !- par_orix : Origin of the slab of data within the X axis (pim) 197 !- par_szx : Size of the slab of data in X 198 !- par_oriy : Origin of the slab of data within the Y axis (pjm) 199 !- par_szy : Size of the slab of data in Y 200 !- 201 !- pitau0 : time step at which the history tape starts 202 !- pdate0 : The Julian date at which the itau was equal to 0 203 !- pdeltat : Time step in seconds. Time step of the counter itau 204 !- used in histwrite for instance 205 !- 206 !- OUTPUT 207 !- 208 !- phoriid : ID of the horizontal grid 209 !- pfileid : ID of the netcdf file 210 !- 211 !- Optional INPUT arguments 212 !- 213 !- domain_id : Domain identifier 214 !- 215 !- TO DO 216 !- 217 !- This package should be written in f90 218 !- and use the following features : 219 !- - structures for the meta-data of the files and variables 220 !- - memory allocation as needed 221 !- - Pointers 222 !- 223 !- VERSION 224 !- 162 SUBROUTINE histb_reg1d & 163 & (pfilename,pim,plon,pjm,plat, & 164 & par_orix,par_szx,par_oriy,par_szy, & 165 & pitau0,pdate0,pdeltat,phoriid,idf,domain_id,mode) 166 !--------------------------------------------------------------------- 167 !- histbeg for 1D regular horizontal coordinates (see histb_all) 225 168 !--------------------------------------------------------------------- 226 169 IMPLICIT NONE … … 233 176 INTEGER,INTENT(IN) :: pitau0 234 177 REAL,INTENT(IN) :: pdate0,pdeltat 235 INTEGER,INTENT(OUT) :: pfileid,phoriid178 INTEGER,INTENT(OUT) :: idf,phoriid 236 179 INTEGER,INTENT(IN),OPTIONAL :: domain_id 237 !- 238 REAL,ALLOCATABLE,DIMENSION(:,:) :: lon_tmp,lat_tmp 239 LOGICAL :: l_dbg 240 !--------------------------------------------------------------------- 241 CALL ipsldbg (old_status=l_dbg) 242 !- 243 IF (l_dbg) WRITE(*,*) "histbeg_totreg" 244 !- 245 ALLOCATE(lon_tmp(pim,pjm),lat_tmp(pim,pjm)) 246 !- 247 lon_tmp(:,:) = SPREAD(plon(:),2,pjm) 248 lat_tmp(:,:) = SPREAD(plat(:),1,pim) 249 !- 250 CALL histbeg_regular & 251 & (pfilename,pim,lon_tmp,pjm,lat_tmp, & 252 & par_orix,par_szx,par_oriy,par_szy, & 253 & pitau0,pdate0,pdeltat,phoriid,pfileid, & 254 & .TRUE.,domain_id) 255 !- 256 DEALLOCATE(lon_tmp,lat_tmp) 257 !---------------------------- 258 END SUBROUTINE histbeg_totreg 180 CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode 181 !--------------------------------------------------------------------- 182 CALL histb_all & 183 & (1,pfilename,pim,pjm,pitau0,pdate0,pdeltat,phoriid,idf, & 184 & x_1d=plon,y_1d=plat, & 185 & k_orx=par_orix,k_szx=par_szx,k_ory=par_oriy,k_szy=par_szy, & 186 & domain_id=domain_id,mode=mode) 187 !------------------------- 188 END SUBROUTINE histb_reg1d 259 189 !=== 260 SUBROUTINE histbeg_regular & 261 & (pfilename,pim,plon,pjm,plat, & 262 & par_orix,par_szx,par_oriy,par_szy, & 263 & pitau0,pdate0,pdeltat,phoriid,pfileid, & 264 & opt_rectilinear,domain_id) 265 !--------------------------------------------------------------------- 266 !- This subroutine initializes a netcdf file and returns the ID. 267 !- It will set up the geographical space on which the data will be 268 !- stored and offers the possibility of seting a zoom. 269 !- It also gets the global parameters into the I/O subsystem. 270 !- 271 !- INPUT 272 !- 273 !- pfilename : Name of the netcdf file to be created 274 !- pim : Size of arrays in longitude direction 275 !- plon : Coordinates of points in longitude 276 !- pjm : Size of arrays in latitude direction 277 !- plat : Coordinates of points in latitude 278 !- 279 !- The next 4 arguments allow to define a horizontal zoom 280 !- for this file. It is assumed that all variables to come 281 !- have the same index space. This can not be assumed for 282 !- the z axis and thus we define the zoom in histdef. 283 !- 284 !- par_orix : Origin of the slab of data within the X axis (pim) 285 !- par_szx : Size of the slab of data in X 286 !- par_oriy : Origin of the slab of data within the Y axis (pjm) 287 !- par_szy : Size of the slab of data in Y 288 !- 289 !- pitau0 : time step at which the history tape starts 290 !- pdate0 : The Julian date at which the itau was equal to 0 291 !- pdeltat : Time step in seconds. Time step of the counter itau 292 !- used in histwrite for instance 293 !- 294 !- OUTPUT 295 !- 296 !- phoriid : ID of the horizontal grid 297 !- pfileid : ID of the netcdf file 298 !- 299 !- Optional INPUT arguments 300 !- 301 !- opt_rectilinear : If true we know the grid is rectilinear 302 !- domain_id : Domain identifier 303 !- 304 !- TO DO 305 !- 306 !- This package should be written in F90 and use the following 307 !- feature : 308 !- - structures for the meta-data of the files and variables 309 !- - memory allocation as needed 310 !- - Pointers 311 !- 312 !- VERSION 313 !- 190 SUBROUTINE histb_reg2d & 191 & (pfilename,pim,plon,pjm,plat, & 192 & par_orix,par_szx,par_oriy,par_szy, & 193 & pitau0,pdate0,pdeltat,phoriid,idf,domain_id,mode) 194 !--------------------------------------------------------------------- 195 !- histbeg for 2D regular horizontal coordinates (see histb_all) 314 196 !--------------------------------------------------------------------- 315 197 IMPLICIT NONE … … 321 203 INTEGER,INTENT(IN) :: pitau0 322 204 REAL,INTENT(IN) :: pdate0,pdeltat 323 INTEGER,INTENT(OUT) :: pfileid,phoriid 324 LOGICAL,INTENT(IN),OPTIONAL :: opt_rectilinear 205 INTEGER,INTENT(OUT) :: idf,phoriid 325 206 INTEGER,INTENT(IN),OPTIONAL :: domain_id 326 !- 327 INTEGER :: ncid,iret 328 CHARACTER(LEN=120) :: file 329 CHARACTER(LEN=30) :: timenow 330 LOGICAL :: rectilinear 331 LOGICAL :: l_dbg 332 !--------------------------------------------------------------------- 333 CALL ipsldbg (old_status=l_dbg) 334 !- 335 nb_files = nb_files+1 336 pfileid = nb_files 337 !- 338 ! 1.0 Transfering into the common for future use 339 !- 340 IF (l_dbg) WRITE(*,*) "histbeg_regular 1.0" 341 !- 342 itau0(pfileid) = pitau0 343 date0(pfileid) = pdate0 344 deltat(pfileid) = pdeltat 345 !- 346 IF (PRESENT(opt_rectilinear)) THEN 347 rectilinear = opt_rectilinear 348 ELSE 349 rectilinear = .FALSE. 350 ENDIF 351 !- 352 ! 2.0 Initializes all variables for this file 353 !- 354 IF (l_dbg) WRITE(*,*) "histbeg_regular 2.0" 355 !- 356 IF (nb_files > nb_files_max) THEN 357 CALL ipslerr (3,"histbeg", & 358 & 'Table of files too small. You should increase nb_files_max', & 359 & 'in histcom.f90 in order to accomodate all these files',' ') 360 ENDIF 361 !- 362 nb_var(pfileid) = 0 363 nb_tax(pfileid) = 0 364 nb_hax(pfileid) = 0 365 nb_zax(pfileid) = 0 366 !- 367 slab_ori(pfileid,1:2) = (/ par_orix,par_oriy /) 368 slab_sz(pfileid,1:2) = (/ par_szx, par_szy /) 369 !- 370 ! 3.0 Opening netcdf file and defining dimensions 371 !- 372 IF (l_dbg) WRITE(*,*) "histbeg_regular 3.0" 373 !- 374 ! Add DOMAIN number and ".nc" suffix in file name if needed 375 !- 376 file = pfilename 377 CALL flio_dom_file (file,domain_id) 378 !- 379 iret = NF90_CREATE (file,NF90_CLOBBER,ncid) 380 !- 381 IF (rectilinear) THEN 382 iret = NF90_DEF_DIM (ncid,'lon',par_szx,xid(nb_files)) 383 iret = NF90_DEF_DIM (ncid,'lat',par_szy,yid(nb_files)) 384 ELSE 385 iret = NF90_DEF_DIM (ncid,'x',par_szx,xid(nb_files)) 386 iret = NF90_DEF_DIM (ncid,'y',par_szy,yid(nb_files)) 387 ENDIF 388 !- 389 ! 4.0 Declaring the geographical coordinates and other attributes 390 !- 391 IF (l_dbg) WRITE(*,*) "histbeg_regular 4.0" 392 !- 393 ! 4.3 Global attributes 394 !- 395 iret = NF90_PUT_ATT (ncid,NF90_GLOBAL,'Conventions','CF-1.1') 396 iret = NF90_PUT_ATT (ncid,NF90_GLOBAL,'file_name',TRIM(file)) 397 iret = NF90_PUT_ATT (ncid,NF90_GLOBAL,'production',TRIM(model_name)) 398 lock_modname = .TRUE. 399 CALL ioget_timestamp (timenow) 400 iret = NF90_PUT_ATT (ncid,NF90_GLOBAL,'TimeStamp',TRIM(timenow)) 401 !- 402 ! 5.0 Saving some important information on this file in the common 403 !- 404 IF (l_dbg) WRITE(*,*) "histbeg_regular 5.0" 405 !- 406 IF (PRESENT(domain_id)) THEN 407 dom_id_svg(pfileid) = domain_id 408 ENDIF 409 ncdf_ids(pfileid) = ncid 410 full_size(pfileid,1:2) = (/ pim,pjm /) 411 !- 412 ! 6.0 storing the geographical coordinates 413 !- 414 zoom(pfileid) = (pim /= par_szx).OR.(pjm /= par_szy) 415 regular(pfileid)=.TRUE. 416 !- 417 CALL histhori_regular (pfileid,pim,plon,pjm,plat, & 418 & ' ' ,'Default grid',phoriid,rectilinear) 419 !----------------------------- 420 END SUBROUTINE histbeg_regular 207 CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode 208 !--------------------------------------------------------------------- 209 CALL histb_all & 210 & (2,pfilename,pim,pjm,pitau0,pdate0,pdeltat,phoriid,idf, & 211 & x_2d=plon,y_2d=plat, & 212 & k_orx=par_orix,k_szx=par_szx,k_ory=par_oriy,k_szy=par_szy, & 213 & domain_id=domain_id,mode=mode) 214 !------------------------- 215 END SUBROUTINE histb_reg2d 421 216 !=== 422 SUBROUTINE histbeg_irregular & 423 & (pfilename,pim,plon,plon_bounds,plat,plat_bounds, & 424 & pitau0,pdate0,pdeltat,phoriid,pfileid,domain_id) 425 !--------------------------------------------------------------------- 426 !- This subroutine initializes a netcdf file and returns the ID. 427 !- This version is for totaly irregular grids. In this case all 428 !- all the data comes in as vectors and for the grid we have 429 !- the coordinates of the 4 corners. 430 !- It also gets the global parameters into the I/O subsystem. 431 !- 432 !- INPUT 433 !- 434 !- pfilename : Name of the netcdf file to be created 435 !- pim : Size of arrays in longitude direction 436 !- plon : Coordinates of points in longitude 437 !- plon_bounds : The 2 corners of the grid in longitude 438 !- plat : Coordinates of points in latitude 439 !- plat_bounds : The 2 corners of the grid in latitude 440 !- 441 !- pitau0 : time step at which the history tape starts 442 !- pdate0 : The Julian date at which the itau was equal to 0 443 !- pdeltat : Time step in seconds. Time step of the counter itau 444 !- used in histwrite for instance 445 !- 446 !- OUTPUT 447 !- 448 !- phoriid : ID of the horizontal grid 449 !- pfileid : ID of the netcdf file 450 !- 451 !- Optional INPUT arguments 452 !- 453 !- domain_id : Domain identifier 454 !- 455 !- TO DO 456 !- 457 !- This package should be written in F90 and use the following 458 !- feature : 459 !- - structures for the meta-data of the files and variables 460 !- - memory allocation as needed 461 !- - Pointers 462 !- 463 !- VERSION 464 !- 217 SUBROUTINE histb_irreg & 218 & (pfilename,pim,plon,plon_bounds,plat,plat_bounds, & 219 & pitau0,pdate0,pdeltat,phoriid,idf,domain_id,mode) 220 !--------------------------------------------------------------------- 221 !- histbeg for irregular horizontal coordinates (see histb_all) 465 222 !--------------------------------------------------------------------- 466 223 IMPLICIT NONE … … 472 229 INTEGER,INTENT(IN) :: pitau0 473 230 REAL,INTENT(IN) :: pdate0,pdeltat 474 INTEGER,INTENT(OUT) :: pfileid,phoriid231 INTEGER,INTENT(OUT) :: idf,phoriid 475 232 INTEGER,INTENT(IN),OPTIONAL :: domain_id 476 !- 477 INTEGER :: ncid,iret 233 CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode 234 !--------------------------------------------------------------------- 235 CALL histb_all & 236 & (3,pfilename,pim,pim,pitau0,pdate0,pdeltat,phoriid,idf, & 237 & x_1d=plon,y_1d=plat,x_bnds=plon_bounds,y_bnds=plat_bounds, & 238 & domain_id=domain_id,mode=mode) 239 !------------------------- 240 END SUBROUTINE histb_irreg 241 !=== 242 SUBROUTINE histb_all & 243 & (k_typ,nc_name,pim,pjm,pitau0,pdate0,pdeltat,phoriid,idf, & 244 & x_1d,y_1d,x_2d,y_2d,k_orx,k_szx,k_ory,k_szy, & 245 & x_bnds,y_bnds,domain_id,mode) 246 !--------------------------------------------------------------------- 247 !- General interface for horizontal grids. 248 !- This subroutine initializes a netcdf file and returns the ID. 249 !- It will set up the geographical space on which the data will be 250 !- stored and offers the possibility of seting a zoom. 251 !- In the case of irregular grids, all the data comes in as vectors 252 !- and for the grid we have the coordinates of the 4 corners. 253 !- It also gets the global parameters into the I/O subsystem. 254 !- 255 !- INPUT 256 !- 257 !- k_typ : Type of the grid (1 rectilinear, 2 regular, 3 irregular) 258 !- nc_name : Name of the netcdf file to be created 259 !- pim : Size of arrays in longitude direction 260 !- pjm : Size of arrays in latitude direction (pjm=pim for type 3) 261 !- 262 !- pitau0 : time step at which the history tape starts 263 !- pdate0 : The Julian date at which the itau was equal to 0 264 !- pdeltat : Time step, in seconds, of the counter itau 265 !- used in histwrite for instance 266 !- 267 !- OUTPUT 268 !- 269 !- phoriid : Identifier of the horizontal grid 270 !- idf : Identifier of the file 271 !- 272 !- Optional INPUT arguments 273 !- 274 !- For rectilinear or irregular grid 275 !- x_1d : The longitudes 276 !- y_1d : The latitudes 277 !- For regular grid 278 !- x_2d : The longitudes 279 !- y_2d : The latitudes 280 !- One pair (x_1d,y_1d) or (x_2d,y_2d) must be supplied. 281 !- 282 !- For regular grid (reg1d or reg2d), 283 !- the next 4 arguments allow to define a horizontal zoom 284 !- for this file. It is assumed that all variables to come 285 !- have the same index space. This can not be assumed for 286 !- the z axis and thus we define the zoom in histdef. 287 !- k_orx : Origin of the slab of data within the X axis (pim) 288 !- k_szx : Size of the slab of data in X 289 !- k_ory : Origin of the slab of data within the Y axis (pjm) 290 !- k_szy : Size of the slab of data in Y 291 !- 292 !- For irregular grid. 293 !- x_bnds : The boundaries of the grid in longitude 294 !- y_bnds : The boundaries of the grid in latitude 295 !- 296 !- For all grids. 297 !- 298 !- domain_id : Domain identifier 299 !- 300 !- mode : String of (case insensitive) blank-separated words 301 !- defining the mode used to create the file. 302 !- Supported keywords : 32, 64 303 !- "32/64" defines the offset mode. 304 !- The default offset mode is 64 bits. 305 !- Keywords "NETCDF4" and "CLASSIC" are reserved 306 !- for future use. 307 !--------------------------------------------------------------------- 308 IMPLICIT NONE 309 !- 310 INTEGER,INTENT(IN) :: k_typ 311 CHARACTER(LEN=*),INTENT(IN) :: nc_name 312 INTEGER,INTENT(IN) :: pim,pjm 313 INTEGER,INTENT(IN) :: pitau0 314 REAL,INTENT(IN) :: pdate0,pdeltat 315 INTEGER,INTENT(OUT) :: idf,phoriid 316 REAL,DIMENSION(:),INTENT(IN),OPTIONAL :: x_1d,y_1d 317 REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_2d,y_2d 318 INTEGER,INTENT(IN),OPTIONAL :: k_orx,k_szx,k_ory,k_szy 319 REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_bnds,y_bnds 320 INTEGER,INTENT(IN),OPTIONAL :: domain_id 321 CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode 322 !- 323 INTEGER :: nfid,iret,m_c 478 324 CHARACTER(LEN=120) :: file 479 325 CHARACTER(LEN=30) :: timenow 326 CHARACTER(LEN=11) :: c_nam 480 327 LOGICAL :: l_dbg 481 328 !--------------------------------------------------------------------- 482 329 CALL ipsldbg (old_status=l_dbg) 483 330 !- 484 nb_files = nb_files+1 485 pfileid = nb_files 486 !- 487 ! 1.0 Transfering into the common for future use 488 !- 489 IF (l_dbg) WRITE(*,*) "histbeg_irregular 1.0" 490 !- 491 itau0(pfileid) = pitau0 492 date0(pfileid) = pdate0 493 deltat(pfileid) = pdeltat 494 !- 495 ! 2.0 Initializes all variables for this file 496 !- 497 IF (l_dbg) WRITE(*,*) "histbeg_irregular 2.0" 498 !- 499 IF (nb_files > nb_files_max) THEN 331 IF (k_typ == 1) THEN 332 c_nam = 'histb_reg1d' 333 ELSEIF (k_typ == 2) THEN 334 c_nam = 'histb_reg2d' 335 ELSEIF (k_typ == 3) THEN 336 c_nam = 'histb_irreg' 337 ELSE 338 CALL ipslerr (3,"histbeg", & 339 & 'Illegal value of k_typ argument','in internal interface','?') 340 ENDIF 341 !- 342 IF (l_dbg) WRITE(*,*) c_nam//" 0.0" 343 !- 344 ! Search for a free index 345 !- 346 idf = -1 347 DO nfid=1,nb_files_max 348 IF (W_F(nfid)%ncfid < 0) THEN 349 idf = nfid; EXIT; 350 ENDIF 351 ENDDO 352 IF (idf < 0) THEN 500 353 CALL ipslerr (3,"histbeg", & 501 354 & 'Table of files too small. You should increase nb_files_max', & … … 503 356 ENDIF 504 357 !- 505 nb_var(pfileid) = 0 506 nb_tax(pfileid) = 0 507 nb_hax(pfileid) = 0 508 nb_zax(pfileid) = 0 509 !- 510 slab_ori(pfileid,1:2) = (/ 1,1 /) 511 slab_sz(pfileid,1:2) = (/ pim,1 /) 358 ! 1.0 Transfering into the common for future use 359 !- 360 IF (l_dbg) WRITE(*,*) c_nam//" 1.0" 361 !- 362 W_F(idf)%itau0 = pitau0 363 W_F(idf)%date0 = pdate0 364 W_F(idf)%deltat = pdeltat 365 !- 366 ! 2.0 Initializes all variables for this file 367 !- 368 IF (l_dbg) WRITE(*,*) c_nam//" 2.0" 369 !- 370 W_F(idf)%n_var = 0 371 W_F(idf)%n_tax = 0 372 W_F(idf)%n_hax = 0 373 W_F(idf)%n_zax = 0 374 !- 375 IF ( (k_typ == 1).OR.(k_typ == 2) ) THEN 376 W_F(idf)%slab_ori(1:2) = (/ k_orx,k_ory /) 377 W_F(idf)%slab_siz(1:2) = (/ k_szx,k_szy /) 378 ELSE 379 W_F(idf)%slab_ori(1:2) = (/ 1,1 /) 380 W_F(idf)%slab_siz(1:2) = (/ pim,1 /) 381 ENDIF 512 382 !- 513 383 ! 3.0 Opening netcdf file and defining dimensions 514 384 !- 515 IF (l_dbg) WRITE(*,*) "histbeg_irregular3.0"385 IF (l_dbg) WRITE(*,*) c_nam//" 3.0" 516 386 !- 517 387 ! Add DOMAIN number and ".nc" suffix in file name if needed 518 388 !- 519 file = pfilename389 file = nc_name 520 390 CALL flio_dom_file (file,domain_id) 521 391 !- 522 iret = NF90_CREATE (file,NF90_CLOBBER,ncid) 523 !- 524 iret = NF90_DEF_DIM (ncid,'x',pim,xid(nb_files)) 525 yid(nb_files) = 0 392 ! Check the mode 393 !? See fliocom for HDF4 ???????????????????????????????????????????????? 394 !- 395 IF (PRESENT(mode)) THEN 396 SELECT CASE (TRIM(mode)) 397 CASE('32') 398 m_c = NF90_CLOBBER 399 CASE('64') 400 m_c = IOR(NF90_CLOBBER,NF90_64BIT_OFFSET) 401 CASE DEFAULT 402 CALL ipslerr (3,"histbeg", & 403 & 'Invalid argument mode for file :',TRIM(file), & 404 & 'Supported values are 32 or 64') 405 END SELECT 406 ELSE 407 m_c = IOR(NF90_CLOBBER,NF90_64BIT_OFFSET) 408 ENDIF 409 !- 410 ! Create file 411 !- 412 iret = NF90_CREATE(file,m_c,nfid) 413 !- 414 IF (k_typ == 1) THEN 415 iret = NF90_DEF_DIM(nfid,'lon',k_szx,W_F(idf)%xid) 416 iret = NF90_DEF_DIM(nfid,'lat',k_szy,W_F(idf)%yid) 417 ELSEIF (k_typ == 2) THEN 418 iret = NF90_DEF_DIM(nfid,'x',k_szx,W_F(idf)%xid) 419 iret = NF90_DEF_DIM(nfid,'y',k_szy,W_F(idf)%yid) 420 ELSEIF (k_typ == 3) THEN 421 iret = NF90_DEF_DIM(nfid,'x',pim,W_F(idf)%xid) 422 W_F(idf)%yid = W_F(idf)%xid 423 ENDIF 526 424 !- 527 425 ! 4.0 Declaring the geographical coordinates and other attributes 528 426 !- 529 IF (l_dbg) WRITE(*,*) "histbeg_irregular 4.0" 530 !- 531 ! 4.3 Global attributes 532 !- 533 iret = NF90_PUT_ATT (ncid,NF90_GLOBAL,'Conventions','CF-1.1') 534 iret = NF90_PUT_ATT (ncid,NF90_GLOBAL,'file_name',TRIM(file)) 535 iret = NF90_PUT_ATT (ncid,NF90_GLOBAL,'production',TRIM(model_name)) 427 IF (l_dbg) WRITE(*,*) c_nam//" 4.0" 428 !- 429 iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'Conventions','CF-1.1') 430 iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'file_name',TRIM(file)) 431 iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'production',TRIM(model_name)) 536 432 lock_modname = .TRUE. 537 433 CALL ioget_timestamp (timenow) 538 iret = NF90_PUT_ATT (ncid,NF90_GLOBAL,'TimeStamp',TRIM(timenow))434 iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'TimeStamp',TRIM(timenow)) 539 435 !- 540 436 ! 5.0 Saving some important information on this file in the common 541 437 !- 542 IF (l_dbg) WRITE(*,*) "histbeg_irregular5.0"438 IF (l_dbg) WRITE(*,*) c_nam//" 5.0" 543 439 !- 544 440 IF (PRESENT(domain_id)) THEN 545 dom_id_svg(pfileid) = domain_id 546 ENDIF 547 ncdf_ids(pfileid) = ncid 548 full_size(pfileid,1:2) = (/ pim,1 /) 441 W_F(idf)%dom_id_svg = domain_id 442 ENDIF 443 W_F(idf)%ncfid = nfid 444 IF ( (k_typ == 1).OR.(k_typ == 2) ) THEN 445 W_F(idf)%full_size(1:2) = (/ pim,pjm /) 446 W_F(idf)%regular=.TRUE. 447 ELSEIF (k_typ == 3) THEN 448 W_F(idf)%full_size(1:2) = (/ pim,1 /) 449 W_F(idf)%regular=.FALSE. 450 ENDIF 549 451 !- 550 452 ! 6.0 storing the geographical coordinates 551 453 !- 552 zoom(pfileid)=.FALSE. 553 regular(pfileid)=.FALSE. 554 !- 555 CALL histhori_irregular & 556 & (pfileid,pim,plon,plon_bounds,plat,plat_bounds, & 557 & ' ' ,'Default grid',phoriid) 558 !------------------------------- 559 END SUBROUTINE histbeg_irregular 454 IF (k_typ == 1) THEN 455 CALL histh_all & 456 & (k_typ,idf,pim,pjm,' ','Default grid',phoriid, & 457 & x_1d=x_1d,y_1d=y_1d) 458 ELSEIF (k_typ == 2) THEN 459 CALL histh_all & 460 & (k_typ,idf,pim,pjm,' ','Default grid',phoriid, & 461 & x_2d=x_2d,y_2d=y_2d) 462 ELSEIF (k_typ == 3) THEN 463 CALL histh_all & 464 & (k_typ,idf,pim,pim,' ','Default grid',phoriid, & 465 & x_1d=x_1d,y_1d=y_1d,x_bnds=x_bnds,y_bnds=y_bnds) 466 ENDIF 467 !----------------------- 468 END SUBROUTINE histb_all 560 469 !=== 561 SUBROUTINE histhori_regular & 562 & (pfileid,pim,plon,pjm,plat,phname,phtitle,phid,opt_rectilinear) 563 !--------------------------------------------------------------------- 564 !- This subroutine is made to declare a new horizontale grid. 470 SUBROUTINE histh_reg1d & 471 & (idf,pim,plon,pjm,plat,phname,phtitle,phid) 472 !--------------------------------------------------------------------- 473 !- histhori for 1d regular grid (see histh_all) 474 !--------------------------------------------------------------------- 475 IMPLICIT NONE 476 !- 477 INTEGER,INTENT(IN) :: idf,pim,pjm 478 REAL,INTENT(IN),DIMENSION(:) :: plon,plat 479 CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle 480 INTEGER,INTENT(OUT) :: phid 481 !--------------------------------------------------------------------- 482 CALL histh_all & 483 & (1,idf,pim,pjm,phname,phtitle,phid,x_1d=plon,y_1d=plat) 484 !------------------------- 485 END SUBROUTINE histh_reg1d 486 !=== 487 SUBROUTINE histh_reg2d & 488 & (idf,pim,plon,pjm,plat,phname,phtitle,phid) 489 !--------------------------------------------------------------------- 490 !- histhori for 2d regular grid (see histh_all) 491 !--------------------------------------------------------------------- 492 IMPLICIT NONE 493 !- 494 INTEGER,INTENT(IN) :: idf,pim,pjm 495 REAL,INTENT(IN),DIMENSION(:,:) :: plon,plat 496 CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle 497 INTEGER,INTENT(OUT) :: phid 498 !--------------------------------------------------------------------- 499 CALL histh_all & 500 & (2,idf,pim,pjm,phname,phtitle,phid,x_2d=plon,y_2d=plat) 501 !------------------------- 502 END SUBROUTINE histh_reg2d 503 !=== 504 SUBROUTINE histh_irreg & 505 & (idf,pim,plon,plon_bounds,plat,plat_bounds,phname,phtitle,phid) 506 !--------------------------------------------------------------------- 507 !- histhori for irregular grid (see histh_all) 508 !--------------------------------------------------------------------- 509 IMPLICIT NONE 510 !- 511 INTEGER,INTENT(IN) :: idf,pim 512 REAL,DIMENSION(:),INTENT(IN) :: plon,plat 513 REAL,DIMENSION(:,:),INTENT(IN) :: plon_bounds,plat_bounds 514 CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle 515 INTEGER,INTENT(OUT) :: phid 516 !--------------------------------------------------------------------- 517 CALL histh_all & 518 & (3,idf,pim,pim,phname,phtitle,phid, & 519 & x_1d=plon,y_1d=plat,x_bnds=plon_bounds,y_bnds=plat_bounds) 520 !------------------------- 521 END SUBROUTINE histh_irreg 522 !=== 523 SUBROUTINE histh_all & 524 & (k_typ,idf,pim,pjm,phname,phtitle,phid, & 525 & x_1d,y_1d,x_2d,y_2d,x_bnds,y_bnds) 526 !--------------------------------------------------------------------- 527 !- General interface for horizontal grids. 528 !- This subroutine is made to declare a new horizontal grid. 565 529 !- It has to have the same number of points as 566 530 !- the original and thus in this routine we will only … … 572 536 !- INPUT 573 537 !- 574 !- pfileid : The id of the file to which the grid should be added 538 !- k_typ : Type of the grid (1 rectilinear, 2 regular, 3 irregular) 539 !- idf : The id of the file to which the grid should be added 575 540 !- pim : Size in the longitude direction 576 !- plon : The longitudes 577 !- pjm : Size in the latitude direction 578 !- plat : The latitudes 541 !- pjm : Size in the latitude direction (pjm=pim for type 3) 579 542 !- phname : The name of grid 580 543 !- phtitle : The title of the grid … … 584 547 !- phid : Id of the created grid 585 548 !- 586 !- OPTIONAL 587 !- 588 !- opt_rectilinear : If true we know the grid is rectilinear. 589 !- 549 !- Optional INPUT arguments 550 !- 551 !- For rectilinear or irregular grid 552 !- x_1d : The longitudes 553 !- y_1d : The latitudes 554 !- For regular grid 555 !- x_2d : The longitudes 556 !- y_2d : The latitudes 557 !- One pair (x_1d,y_1d) or (x_2d,y_2d) must be supplied. 558 !- 559 !- For irregular grid. 560 !- x_bnds : The boundaries of the grid in longitude 561 !- y_bnds : The boundaries of the grid in latitude 590 562 !--------------------------------------------------------------------- 591 563 IMPLICIT NONE 592 564 !- 593 INTEGER,INTENT(IN) :: pfileid,pim,pjm594 REAL,INTENT(IN),DIMENSION(pim,pjm) :: plon,plat565 INTEGER,INTENT(IN) :: k_typ 566 INTEGER,INTENT(IN) :: idf,pim,pjm 595 567 CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle 596 568 INTEGER,INTENT(OUT) :: phid 597 LOGICAL,INTENT(IN),OPTIONAL :: opt_rectilinear 569 REAL,DIMENSION(:),INTENT(IN),OPTIONAL :: x_1d,y_1d 570 REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_2d,y_2d 571 REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_bnds,y_bnds 598 572 !- 599 573 CHARACTER(LEN=25) :: lon_name,lat_name 600 CHARACTER(LEN=80) :: tmp_title,tmp_name 601 INTEGER :: ndim 602 INTEGER,DIMENSION(2) :: dims 574 CHARACTER(LEN=30) :: lonbound_name,latbound_name 575 INTEGER :: i_s,i_e 576 INTEGER,DIMENSION(2) :: dims,dims_b 577 INTEGER :: nbbounds 578 INTEGER :: nlonidb,nlatidb,twoid 579 LOGICAL :: transp = .FALSE. 580 REAL,ALLOCATABLE,DIMENSION(:,:) :: bounds_trans 581 REAL :: wmn,wmx 603 582 INTEGER :: nlonid,nlatid 604 INTEGER :: o rix,oriy,par_szx,par_szy605 INTEGER :: iret,n cid606 LOGICAL :: rectilinear583 INTEGER :: o_x,o_y,s_x,s_y 584 INTEGER :: iret,nfid 585 CHARACTER(LEN=11) :: c_nam 607 586 LOGICAL :: l_dbg 608 587 !--------------------------------------------------------------------- 609 588 CALL ipsldbg (old_status=l_dbg) 610 589 !- 590 IF (k_typ == 1) THEN 591 c_nam = 'histh_reg1d' 592 ELSEIF (k_typ == 2) THEN 593 c_nam = 'histh_reg2d' 594 ELSEIF (k_typ == 3) THEN 595 c_nam = 'histh_irreg' 596 ELSE 597 CALL ipslerr (3,"histhori", & 598 & 'Illegal value of k_typ argument','in internal interface','?') 599 ENDIF 600 !- 611 601 ! 1.0 Check that all fits in the buffers 612 602 !- 613 IF ( (pim /= full_size(pfileid,1)) & 614 & .OR.(pjm /= full_size(pfileid,2)) ) THEN 603 IF ( (pim /= W_F(idf)%full_size(1)) & 604 & .OR.(W_F(idf)%regular.AND.(pjm /= W_F(idf)%full_size(2))) & 605 & .OR.(.NOT.W_F(idf)%regular.AND.(W_F(idf)%full_size(2) /= 1)) ) THEN 615 606 CALL ipslerr (3,"histhori", & 616 & 'The new horizontal grid does not have the same size', & 617 & 'as the one provided to histbeg. This is not yet ', & 618 & 'possible in the hist package.') 619 ENDIF 620 !- 621 IF (PRESENT(opt_rectilinear)) THEN 622 rectilinear = opt_rectilinear 623 ELSE 624 rectilinear = .FALSE. 607 & 'The new horizontal grid does not have the same size', & 608 & 'as the one provided to histbeg. This is not yet ', & 609 & 'possible in the hist package.') 625 610 ENDIF 626 611 !- 627 612 ! 1.1 Create all the variables needed 628 613 !- 629 IF (l_dbg) WRITE(*,*) "histhori_regular 1.0" 630 !- 631 ncid = ncdf_ids(pfileid) 632 !- 633 ndim = 2 634 dims(1:2) = (/ xid(pfileid),yid(pfileid) /) 635 !- 636 tmp_name = phname 637 IF (rectilinear) THEN 638 IF (nb_hax(pfileid) == 0) THEN 614 IF (l_dbg) WRITE(*,*) c_nam//" 1.0" 615 !- 616 nfid = W_F(idf)%ncfid 617 !- 618 IF (k_typ == 3) THEN 619 IF (SIZE(x_bnds,DIM=1) == pim) THEN 620 nbbounds = SIZE(x_bnds,DIM=2) 621 transp = .TRUE. 622 ELSEIF (SIZE(x_bnds,DIM=2) == pim) THEN 623 nbbounds = SIZE(x_bnds,DIM=1) 624 transp = .FALSE. 625 ELSE 626 CALL ipslerr (3,"histhori", & 627 & 'The boundary variable does not have any axis corresponding', & 628 & 'to the size of the longitude or latitude variable','.') 629 ENDIF 630 ALLOCATE(bounds_trans(nbbounds,pim)) 631 iret = NF90_DEF_DIM(nfid,'nbnd',nbbounds,twoid) 632 dims_b(1:2) = (/ twoid,W_F(idf)%xid /) 633 ENDIF 634 !- 635 dims(1:2) = (/ W_F(idf)%xid,W_F(idf)%yid /) 636 !- 637 IF (k_typ == 1) THEN 638 IF (W_F(idf)%n_hax == 0) THEN 639 639 lon_name = 'lon' 640 640 lat_name = 'lat' 641 641 ELSE 642 lon_name = 'lon_'//TRIM( tmp_name)643 lat_name = 'lat_'//TRIM( tmp_name)644 ENDIF 645 ELSE 646 IF ( nb_hax(pfileid)== 0) THEN642 lon_name = 'lon_'//TRIM(phname) 643 lat_name = 'lat_'//TRIM(phname) 644 ENDIF 645 ELSEIF (k_typ == 2) THEN 646 IF (W_F(idf)%n_hax == 0) THEN 647 647 lon_name = 'nav_lon' 648 648 lat_name = 'nav_lat' 649 649 ELSE 650 lon_name = 'nav_lon_'//TRIM(tmp_name) 651 lat_name = 'nav_lat_'//TRIM(tmp_name) 652 ENDIF 650 lon_name = 'nav_lon_'//TRIM(phname) 651 lat_name = 'nav_lat_'//TRIM(phname) 652 ENDIF 653 ELSEIF (k_typ == 3) THEN 654 IF (W_F(idf)%n_hax == 0) THEN 655 lon_name = 'nav_lon' 656 lat_name = 'nav_lat' 657 ELSE 658 lon_name = 'nav_lon_'//TRIM(phname) 659 lat_name = 'nav_lat_'//TRIM(phname) 660 ENDIF 661 lonbound_name = TRIM(lon_name)//'_bounds' 662 latbound_name = TRIM(lat_name)//'_bounds' 653 663 ENDIF 654 664 !- 655 665 ! 1.2 Save the informations 656 666 !- 657 phid = nb_hax(pfileid)+1 658 nb_hax(pfileid) = phid 659 !- 660 hax_name(pfileid,phid,1:2) = (/ lon_name,lat_name /) 661 tmp_title = phtitle 667 phid = W_F(idf)%n_hax+1 668 W_F(idf)%n_hax = phid 669 W_F(idf)%hax_name(phid,1:2) = (/ lon_name,lat_name /) 662 670 !- 663 671 ! 2.0 Longitude 664 672 !- 665 IF (l_dbg) WRITE(*,*) "histhori_regular 2.0" 666 !- 667 IF (rectilinear) THEN 668 ndim = 1 669 dims(1:1) = (/ xid(pfileid) /) 670 ENDIF 671 iret = NF90_DEF_VAR (ncid,lon_name,NF90_FLOAT,dims(1:ndim),nlonid) 672 IF (rectilinear) THEN 673 iret = NF90_PUT_ATT (ncid,nlonid,'axis',"X") 674 ENDIF 675 iret = NF90_PUT_ATT (ncid,nlonid,'standard_name',"longitude") 676 iret = NF90_PUT_ATT (ncid,nlonid,'units',"degrees_east") 677 iret = NF90_PUT_ATT (ncid,nlonid,'valid_min', & 678 & REAL(MINVAL(plon),KIND=4)) 679 iret = NF90_PUT_ATT (ncid,nlonid,'valid_max', & 680 & REAL(MAXVAL(plon),KIND=4)) 681 iret = NF90_PUT_ATT (ncid,nlonid,'long_name',"Longitude") 682 iret = NF90_PUT_ATT (ncid,nlonid,'nav_model',TRIM(tmp_title)) 673 IF (l_dbg) WRITE(*,*) c_nam//" 2.0" 674 !- 675 i_s = 1; 676 IF ( (k_typ == 1).OR.(k_typ == 3) ) THEN 677 i_e = 1; wmn = MINVAL(x_1d); wmx = MAXVAL(x_1d); 678 ELSEIF (k_typ == 2) THEN 679 i_e = 2; wmn = MINVAL(x_2d); wmx = MAXVAL(x_2d); 680 ENDIF 681 iret = NF90_DEF_VAR(nfid,lon_name,NF90_REAL4,dims(i_s:i_e),nlonid) 682 IF (k_typ == 1) THEN 683 iret = NF90_PUT_ATT(nfid,nlonid,'axis',"X") 684 ENDIF 685 iret = NF90_PUT_ATT(nfid,nlonid,'standard_name',"longitude") 686 iret = NF90_PUT_ATT(nfid,nlonid,'units',"degrees_east") 687 iret = NF90_PUT_ATT(nfid,nlonid,'valid_min',REAL(wmn,KIND=4)) 688 iret = NF90_PUT_ATT(nfid,nlonid,'valid_max',REAL(wmx,KIND=4)) 689 iret = NF90_PUT_ATT(nfid,nlonid,'long_name',"Longitude") 690 iret = NF90_PUT_ATT(nfid,nlonid,'nav_model',TRIM(phtitle)) 691 !- 692 IF (k_typ == 3) THEN 693 !--- 694 !-- 2.1 Longitude bounds 695 !--- 696 iret = NF90_PUT_ATT(nfid,nlonid,'bounds',TRIM(lonbound_name)) 697 iret = NF90_DEF_VAR(nfid,lonbound_name,NF90_REAL4,dims_b(1:2),nlonidb) 698 iret = NF90_PUT_ATT(nfid,nlonidb,'long_name', & 699 & 'Boundaries for coordinate variable '//TRIM(lon_name)) 700 ENDIF 683 701 !- 684 702 ! 3.0 Latitude 685 703 !- 686 IF (l_dbg) WRITE(*,*) "histhori_regular 3.0" 687 !- 688 IF (rectilinear) THEN 689 ndim = 1 690 dims(1:1) = (/ yid(pfileid) /) 691 ENDIF 692 iret = NF90_DEF_VAR (ncid,lat_name,NF90_FLOAT,dims(1:ndim),nlatid) 693 IF (rectilinear) THEN 694 iret = NF90_PUT_ATT (ncid,nlatid,'axis',"Y") 695 ENDIF 696 iret = NF90_PUT_ATT (ncid,nlatid,'standard_name',"latitude") 697 iret = NF90_PUT_ATT (ncid,nlatid,'units',"degrees_north") 698 iret = NF90_PUT_ATT (ncid,nlatid,'valid_min', & 699 & REAL(MINVAL(plat),KIND=4)) 700 iret = NF90_PUT_ATT (ncid,nlatid,'valid_max', & 701 & REAL(MAXVAL(plat),KIND=4)) 702 iret = NF90_PUT_ATT (ncid,nlatid,'long_name',"Latitude") 703 iret = NF90_PUT_ATT (ncid,nlatid,'nav_model',TRIM(tmp_title)) 704 !- 705 iret = NF90_ENDDEF (ncid) 704 IF (l_dbg) WRITE(*,*) c_nam//" 3.0" 705 !- 706 i_e = 2; 707 IF ( (k_typ == 1).OR.(k_typ == 3) ) THEN 708 i_s = 2; wmn = MINVAL(y_1d); wmx = MAXVAL(y_1d); 709 ELSEIF (k_typ == 2) THEN 710 i_s = 1; wmn = MINVAL(y_2d); wmx = MAXVAL(y_2d); 711 ENDIF 712 iret = NF90_DEF_VAR(nfid,lat_name,NF90_REAL4,dims(i_s:i_e),nlatid) 713 IF (k_typ == 1) THEN 714 iret = NF90_PUT_ATT(nfid,nlatid,'axis',"Y") 715 ENDIF 716 !- 717 iret = NF90_PUT_ATT(nfid,nlatid,'standard_name',"latitude") 718 iret = NF90_PUT_ATT(nfid,nlatid,'units',"degrees_north") 719 iret = NF90_PUT_ATT(nfid,nlatid,'valid_min',REAL(wmn,KIND=4)) 720 iret = NF90_PUT_ATT(nfid,nlatid,'valid_max',REAL(wmx,KIND=4)) 721 iret = NF90_PUT_ATT(nfid,nlatid,'long_name',"Latitude") 722 iret = NF90_PUT_ATT(nfid,nlatid,'nav_model',TRIM(phtitle)) 723 !- 724 IF (k_typ == 3) THEN 725 !--- 726 !-- 3.1 Latitude bounds 727 !--- 728 iret = NF90_PUT_ATT(nfid,nlatid,'bounds',TRIM(latbound_name)) 729 iret = NF90_DEF_VAR(nfid,latbound_name,NF90_REAL4,dims_b(1:2),nlatidb) 730 iret = NF90_PUT_ATT(nfid,nlatidb,'long_name', & 731 & 'Boundaries for coordinate variable '//TRIM(lat_name)) 732 ENDIF 733 !- 734 iret = NF90_ENDDEF(nfid) 706 735 !- 707 736 ! 4.0 storing the geographical coordinates 708 737 !- 709 IF (l_dbg) WRITE(*,*) "histhori_regular 4.0" 710 !- 711 orix = slab_ori(pfileid,1) 712 oriy = slab_ori(pfileid,2) 713 par_szx = slab_sz(pfileid,1) 714 par_szy = slab_sz(pfileid,2) 715 !- 716 ! Transfer the longitude 717 !- 718 IF (rectilinear) THEN 719 iret = NF90_PUT_VAR (ncid,nlonid,plon(orix:orix+par_szx-1,1)) 720 ELSE 721 iret = NF90_PUT_VAR (ncid,nlonid, & 722 & plon(orix:orix+par_szx-1,oriy:oriy+par_szy-1)) 723 ENDIF 724 !- 725 ! Transfer the latitude 726 !- 727 IF (rectilinear) THEN 728 iret = NF90_PUT_VAR (ncid,nlatid,plat(1,oriy:oriy+par_szy-1)) 729 ELSE 730 iret = NF90_PUT_VAR (ncid,nlatid, & 731 & plat(orix:orix+par_szx-1,oriy:oriy+par_szy-1)) 732 ENDIF 733 !- 734 iret = NF90_REDEF (ncid) 735 !------------------------------ 736 END SUBROUTINE histhori_regular 738 IF (l_dbg) WRITE(*,*) c_nam//" 4.0" 739 !- 740 IF ( (k_typ == 1).OR.(k_typ == 2) ) THEN 741 o_x = W_F(idf)%slab_ori(1) 742 o_y = W_F(idf)%slab_ori(2) 743 s_x = W_F(idf)%slab_siz(1) 744 s_y = W_F(idf)%slab_siz(2) 745 !--- 746 !-- Transfer the longitude and the latitude 747 !--- 748 IF (k_typ == 1) THEN 749 iret = NF90_PUT_VAR(nfid,nlonid,x_1d(o_x:o_x+s_x-1)) 750 iret = NF90_PUT_VAR(nfid,nlatid,y_1d(o_y:o_y+s_y-1)) 751 ELSEIF (k_typ == 2) THEN 752 iret = NF90_PUT_VAR(nfid,nlonid, & 753 & x_2d(o_x:o_x+s_x-1,o_y:o_y+s_y-1)) 754 iret = NF90_PUT_VAR(nfid,nlatid, & 755 & y_2d(o_x:o_x+s_x-1,o_y:o_y+s_y-1)) 756 ENDIF 757 ELSEIF (k_typ == 3) THEN 758 !--- 759 !-- Transfer the longitude and the longitude bounds 760 !--- 761 iret = NF90_PUT_VAR(nfid,nlonid,x_1d(1:pim)) 762 !--- 763 IF (transp) THEN 764 bounds_trans = TRANSPOSE(x_bnds) 765 ELSE 766 bounds_trans = x_bnds 767 ENDIF 768 iret = NF90_PUT_VAR(nfid,nlonidb,bounds_trans(1:nbbounds,1:pim)) 769 !--- 770 !-- Transfer the latitude and the latitude bounds 771 !--- 772 iret = NF90_PUT_VAR(nfid,nlatid,y_1d(1:pim)) 773 !--- 774 IF (transp) THEN 775 bounds_trans = TRANSPOSE(y_bnds) 776 ELSE 777 bounds_trans = y_bnds 778 ENDIF 779 iret = NF90_PUT_VAR(nfid,nlatidb,bounds_trans(1:nbbounds,1:pim)) 780 !--- 781 DEALLOCATE(bounds_trans) 782 ENDIF 783 !- 784 iret = NF90_REDEF(nfid) 785 !----------------------- 786 END SUBROUTINE histh_all 737 787 !=== 738 SUBROUTINE histhori_irregular & 739 & (pfileid,pim,plon,plon_bounds,plat,plat_bounds, & 740 & phname,phtitle,phid) 741 !--------------------------------------------------------------------- 742 !- This subroutine is made to declare a new horizontale grid. 743 !- It has to have the same number of points as 744 !- the original and thus in this routine we will only 745 !- add two variable (longitude and latitude). 746 !- Any variable in the file can thus point to this pair 747 !- through an attribute. This routine is very usefull 748 !- to allow staggered grids. 749 !- 750 !- INPUT 751 !- 752 !- pfileid : The id of the file to which the grid should be added 753 !- pim : Size in the longitude direction 754 !- plon : The longitudes 755 !- plon_bounds : The boundaries of the grid in longitude 756 !- plat : The latitudes 757 !- plat_bounds : Boundaries of the grid in latitude 758 !- phname : The name of grid 759 !- phtitle : The title of the grid 760 !- 761 !- OUTPUT 762 !- 763 !- phid : Id of the created grid 764 !--------------------------------------------------------------------- 765 IMPLICIT NONE 766 !- 767 INTEGER,INTENT(IN) :: pfileid,pim 768 REAL,DIMENSION(pim),INTENT(IN) :: plon,plat 769 REAL,DIMENSION(:,:),INTENT(IN) :: plon_bounds,plat_bounds 770 CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle 771 INTEGER,INTENT(OUT) :: phid 772 !- 773 CHARACTER(LEN=25) :: lon_name,lat_name 774 CHARACTER(LEN=30) :: lonbound_name,latbound_name 775 CHARACTER(LEN=80) :: tmp_title,tmp_name,longname 776 INTEGER :: ndim,dims(2) 777 INTEGER :: ndimb,dimsb(2) 778 INTEGER :: nbbounds 779 INTEGER :: nlonid,nlatid,nlonidb,nlatidb 780 INTEGER :: iret,ncid,twoid 781 LOGICAL :: transp = .FALSE. 782 REAL,ALLOCATABLE,DIMENSION(:,:) :: bounds_trans 783 LOGICAL :: l_dbg 784 !--------------------------------------------------------------------- 785 CALL ipsldbg (old_status=l_dbg) 786 !- 787 ! 1.0 Check that all fits in the buffers 788 !- 789 IF ( (pim /= full_size(pfileid,1)) & 790 & .OR.(full_size(pfileid,2) /= 1) ) THEN 791 CALL ipslerr (3,"histhori", & 792 & 'The new horizontal grid does not have the same size', & 793 & 'as the one provided to histbeg. This is not yet ', & 794 & 'possible in the hist package.') 795 ENDIF 796 !- 797 ! 1.1 Create all the variables needed 798 !- 799 IF (l_dbg) WRITE(*,*) 'histhori_irregular 1.0' 800 !- 801 ncid = ncdf_ids(pfileid) 802 !- 803 IF (SIZE(plon_bounds,DIM=1) == pim) THEN 804 nbbounds = SIZE(plon_bounds,DIM=2) 805 transp = .TRUE. 806 ELSEIF (SIZE(plon_bounds,DIM=2) == pim) THEN 807 nbbounds = SIZE(plon_bounds,DIM=1) 808 transp = .FALSE. 809 ELSE 810 CALL ipslerr (3,"histhori", & 811 & 'The boundary variable does not have any axis corresponding', & 812 & 'to the size of the longitude or latitude variable', & 813 & '.') 814 ENDIF 815 !- 816 ALLOCATE(bounds_trans(nbbounds,pim)) 817 !- 818 iret = NF90_DEF_DIM (ncid,'nbnd',nbbounds,twoid) 819 ndim = 1 820 dims(1) = xid(pfileid) 821 ndimb = 2 822 dimsb(1:2) = (/ twoid,xid(pfileid) /) 823 !- 824 tmp_name = phname 825 IF (nb_hax(pfileid) == 0) THEN 826 lon_name = 'nav_lon' 827 lat_name = 'nav_lat' 828 ELSE 829 lon_name = 'nav_lon_'//TRIM(tmp_name) 830 lat_name = 'nav_lat_'//TRIM(tmp_name) 831 ENDIF 832 lonbound_name = TRIM(lon_name)//'_bounds' 833 latbound_name = TRIM(lat_name)//'_bounds' 834 !- 835 ! 1.2 Save the informations 836 !- 837 phid = nb_hax(pfileid)+1 838 nb_hax(pfileid) = phid 839 !- 840 hax_name(pfileid,phid,1:2) = (/ lon_name,lat_name /) 841 tmp_title = phtitle 842 !- 843 ! 2.0 Longitude 844 !- 845 IF (l_dbg) WRITE(*,*) "histhori_irregular 2.0" 846 !- 847 iret = NF90_DEF_VAR (ncid,lon_name,NF90_FLOAT,dims(1:ndim),nlonid) 848 iret = NF90_PUT_ATT (ncid,nlonid,'standard_name',"longitude") 849 iret = NF90_PUT_ATT (ncid,nlonid,'units',"degrees_east") 850 iret = NF90_PUT_ATT (ncid,nlonid,'valid_min', & 851 & REAL(MINVAL(plon),KIND=4)) 852 iret = NF90_PUT_ATT (ncid,nlonid,'valid_max', & 853 & REAL(MAXVAL(plon),KIND=4)) 854 iret = NF90_PUT_ATT (ncid,nlonid,'long_name',"Longitude") 855 iret = NF90_PUT_ATT (ncid,nlonid,'nav_model',TRIM(tmp_title)) 856 !- 857 ! 2.1 Longitude bounds 858 !- 859 iret = NF90_PUT_ATT (ncid,nlonid,'bounds',TRIM(lonbound_name)) 860 iret = NF90_DEF_VAR (ncid,lonbound_name,NF90_FLOAT, & 861 & dimsb(1:ndimb),nlonidb) 862 longname = 'Boundaries for coordinate variable '//TRIM(lon_name) 863 iret = NF90_PUT_ATT (ncid,nlonidb,'long_name',TRIM(longname)) 864 !- 865 ! 3.0 Latitude 866 !- 867 IF (l_dbg) WRITE(*,*) "histhori_irregular 3.0" 868 !- 869 iret = NF90_DEF_VAR (ncid,lat_name,NF90_FLOAT,dims(1:ndim),nlatid) 870 iret = NF90_PUT_ATT (ncid,nlatid,'standard_name',"latitude") 871 iret = NF90_PUT_ATT (ncid,nlatid,'units',"degrees_north") 872 iret = NF90_PUT_ATT (ncid,nlatid,'valid_min', & 873 & REAL(MINVAL(plat),KIND=4)) 874 iret = NF90_PUT_ATT (ncid,nlatid,'valid_max', & 875 & REAL(MAXVAL(plat),KIND=4)) 876 iret = NF90_PUT_ATT (ncid,nlatid,'long_name',"Latitude") 877 iret = NF90_PUT_ATT (ncid,nlatid,'nav_model',TRIM(tmp_title)) 878 !- 879 ! 3.1 Latitude bounds 880 !- 881 iret = NF90_PUT_ATT (ncid,nlatid,'bounds',TRIM(latbound_name)) 882 iret = NF90_DEF_VAR (ncid,latbound_name,NF90_FLOAT, & 883 & dimsb(1:ndimb),nlatidb) 884 longname = 'Boundaries for coordinate variable '//TRIM(lat_name) 885 iret = NF90_PUT_ATT (ncid,nlatidb,'long_name',TRIM(longname)) 886 !- 887 iret = NF90_ENDDEF (ncid) 888 !- 889 ! 4.0 storing the geographical coordinates 890 !- 891 IF (l_dbg) WRITE(*,*) "histhori_irregular 4.0" 892 !- 893 ! 4.1 Write the longitude 894 !- 895 iret = NF90_PUT_VAR (ncid,nlonid,plon(1:pim)) 896 !- 897 ! 4.2 Write the longitude bounds 898 !- 899 IF (transp) THEN 900 bounds_trans = TRANSPOSE(plon_bounds) 901 ELSE 902 bounds_trans = plon_bounds 903 ENDIF 904 iret = NF90_PUT_VAR (ncid,nlonidb,bounds_trans(1:nbbounds,1:pim)) 905 !- 906 ! 4.3 Write the latitude 907 !- 908 iret = NF90_PUT_VAR (ncid,nlatid,plat(1:pim)) 909 !- 910 ! 4.4 Write the latitude bounds 911 !- 912 IF (transp) THEN 913 bounds_trans = TRANSPOSE(plat_bounds) 914 ELSE 915 bounds_trans = plat_bounds 916 ENDIF 917 iret = NF90_PUT_VAR (ncid,nlatidb,bounds_trans(1:nbbounds,1:pim)) 918 !- 919 DEALLOCATE(bounds_trans) 920 !- 921 iret = NF90_REDEF (ncid) 922 !-------------------------------- 923 END SUBROUTINE histhori_irregular 924 !=== 925 SUBROUTINE histvert (pfileid,pzaxname,pzaxtitle,pzaxunit, & 788 SUBROUTINE histvert (idf,pzaxname,pzaxtitle,pzaxunit, & 926 789 & pzsize,pzvalues,pzaxid,pdirect) 927 790 !--------------------------------------------------------------------- … … 933 796 !- INPUT 934 797 !- 935 !- pfileid: ID of the file the variable should be archived in798 !- idf : ID of the file the variable should be archived in 936 799 !- pzaxname : Name of the vertical axis 937 800 !- pzaxtitle: title of the vertical axis … … 952 815 IMPLICIT NONE 953 816 !- 954 INTEGER,INTENT(IN) :: pfileid,pzsize817 INTEGER,INTENT(IN) :: idf,pzsize 955 818 CHARACTER(LEN=*),INTENT(IN) :: pzaxname,pzaxunit,pzaxtitle 956 819 REAL,INTENT(IN) :: pzvalues(pzsize) … … 960 823 INTEGER :: pos,iv,zdimid,zaxid_tmp 961 824 CHARACTER(LEN=70) :: str71 962 CHARACTER(LEN=80) :: str80963 825 CHARACTER(LEN=20) :: direction 964 INTEGER :: iret,leng,n cid826 INTEGER :: iret,leng,nfid 965 827 LOGICAL :: l_dbg 966 828 !--------------------------------------------------------------------- … … 974 836 & pzaxname,'---',pzaxunit,'---',pzaxtitle 975 837 !- 976 ! - Direction of axis. Can we get if from the user. 977 ! If not we put unknown. 838 ! Direction of the vertical axis. Can we get if from the user. 978 839 !- 979 840 IF (PRESENT(pdirect)) THEN … … 986 847 ! Check the consistency of the attribute 987 848 !- 988 IF ( (direction /= 'unknown')&989 & .AND.(direction /= 'up') 990 & .AND.(direction /= 'down') 849 IF ( PRESENT(pdirect) & 850 & .AND.(direction /= 'up') & 851 & .AND.(direction /= 'down') ) THEN 991 852 direction = 'unknown' 992 str80 = 'The specified axis was : '//TRIM(direction)993 853 CALL ipslerr (2,"histvert",& 994 & "The specified direction for the vertical axis is not possible.",&995 & "it is replaced by : unknown",str80)996 ENDIF 997 !- 998 IF ( nb_zax(pfileid)+1 > nb_zax_max) THEN854 & "The specified positive direction for the vertical axis is invalid.",& 855 & "The value must be up or down.","The attribute will not be written.") 856 ENDIF 857 !- 858 IF (W_F(idf)%n_zax+1 > nb_zax_max) THEN 999 859 CALL ipslerr (3,"histvert", & 1000 860 & 'Table of vertical axes too small. You should increase ',& … … 1003 863 ENDIF 1004 864 !- 1005 iv = nb_zax(pfileid)865 iv = W_F(idf)%n_zax 1006 866 IF (iv > 1) THEN 1007 CALL find_str ( zax_name(pfileid,1:iv-1),pzaxname,pos)867 CALL find_str (W_F(idf)%zax_name(1:iv-1),pzaxname,pos) 1008 868 ELSE 1009 869 pos = 0 … … 1012 872 IF (pos > 0) THEN 1013 873 WRITE(str71,'("Check variable ",A," in file",I3)') & 1014 & TRIM(pzaxname), pfileid874 & TRIM(pzaxname),idf 1015 875 CALL ipslerr (3,"histvert", & 1016 876 & "Vertical axis already exists",TRIM(str71), & … … 1018 878 ENDIF 1019 879 !- 1020 iv = nb_zax(pfileid)+1880 iv = W_F(idf)%n_zax+1 1021 881 !- 1022 882 ! 2.0 Add the information to the file … … 1025 885 & WRITE(*,*) "histvert : 2.0 Add the information to the file" 1026 886 !- 1027 n cid = ncdf_ids(pfileid)887 nfid = W_F(idf)%ncfid 1028 888 !- 1029 889 leng = MIN(LEN_TRIM(pzaxname),20) 1030 iret = NF90_DEF_DIM (n cid,pzaxname(1:leng),pzsize,zaxid_tmp)1031 iret = NF90_DEF_VAR (n cid,pzaxname(1:leng),NF90_FLOAT, &890 iret = NF90_DEF_DIM (nfid,pzaxname(1:leng),pzsize,zaxid_tmp) 891 iret = NF90_DEF_VAR (nfid,pzaxname(1:leng),NF90_REAL4, & 1032 892 & zaxid_tmp,zdimid) 1033 iret = NF90_PUT_ATT (n cid,zdimid,'axis',"Z")1034 iret = NF90_PUT_ATT (n cid,zdimid,'standard_name',"model_level_number")893 iret = NF90_PUT_ATT (nfid,zdimid,'axis',"Z") 894 iret = NF90_PUT_ATT (nfid,zdimid,'standard_name',"model_level_number") 1035 895 leng = MIN(LEN_TRIM(pzaxunit),20) 1036 896 IF (leng > 0) THEN 1037 iret = NF90_PUT_ATT (ncid,zdimid,'units',pzaxunit(1:leng)) 1038 ENDIF 1039 iret = NF90_PUT_ATT (ncid,zdimid,'positive',TRIM(direction)) 1040 iret = NF90_PUT_ATT (ncid,zdimid,'valid_min', & 897 iret = NF90_PUT_ATT (nfid,zdimid,'units',pzaxunit(1:leng)) 898 ENDIF 899 IF (direction /= 'unknown') THEN 900 iret = NF90_PUT_ATT (nfid,zdimid,'positive',TRIM(direction)) 901 ENDIF 902 iret = NF90_PUT_ATT (nfid,zdimid,'valid_min', & 1041 903 & REAL(MINVAL(pzvalues(1:pzsize)),KIND=4)) 1042 iret = NF90_PUT_ATT (n cid,zdimid,'valid_max', &904 iret = NF90_PUT_ATT (nfid,zdimid,'valid_max', & 1043 905 & REAL(MAXVAL(pzvalues(1:pzsize)),KIND=4)) 1044 906 leng = MIN(LEN_TRIM(pzaxname),20) 1045 iret = NF90_PUT_ATT (n cid,zdimid,'title',pzaxname(1:leng))907 iret = NF90_PUT_ATT (nfid,zdimid,'title',pzaxname(1:leng)) 1046 908 leng = MIN(LEN_TRIM(pzaxtitle),80) 1047 iret = NF90_PUT_ATT (n cid,zdimid,'long_name',pzaxtitle(1:leng))1048 !- 1049 iret = NF90_ENDDEF (n cid)1050 !- 1051 iret = NF90_PUT_VAR (n cid,zdimid,pzvalues(1:pzsize))1052 !- 1053 iret = NF90_REDEF (n cid)909 iret = NF90_PUT_ATT (nfid,zdimid,'long_name',pzaxtitle(1:leng)) 910 !- 911 iret = NF90_ENDDEF (nfid) 912 !- 913 iret = NF90_PUT_VAR (nfid,zdimid,pzvalues(1:pzsize)) 914 !- 915 iret = NF90_REDEF (nfid) 1054 916 !- 1055 917 !- 3.0 add the information to the common … … 1058 920 & WRITE(*,*) "histvert : 3.0 add the information to the common" 1059 921 !- 1060 nb_zax(pfileid)= iv1061 zax_size(pfileid,iv) = pzsize1062 zax_name(pfileid,iv) = pzaxname1063 zax_ids(pfileid,iv) = zaxid_tmp1064 pzaxid = 922 W_F(idf)%n_zax = iv 923 W_F(idf)%zax_size(iv) = pzsize 924 W_F(idf)%zax_name(iv) = pzaxname 925 W_F(idf)%zax_ids(iv) = zaxid_tmp 926 pzaxid = iv 1065 927 !---------------------- 1066 928 END SUBROUTINE histvert 1067 929 !=== 1068 SUBROUTINE histdef (pfileid,pvarname,ptitle,punit,&1069 & pxsize,pysize,phoriid,pzsize,&1070 & par_oriz,par_szz,pzid,&1071 & pnbbyt,popp,pfreq_opp,pfreq_wrt,var_range)930 SUBROUTINE histdef & 931 & (idf,pvarname,ptitle,punit, & 932 & pxsize,pysize,phoriid,pzsize,par_oriz,par_szz,pzid, & 933 & xtype,popp,pfreq_opp,pfreq_wrt,var_range,standard_name) 1072 934 !--------------------------------------------------------------------- 1073 935 !- With this subroutine each variable to be archived on the history … … 1080 942 !- INPUT 1081 943 !- 1082 !- pfileid: ID of the file the variable should be archived in944 !- idf : ID of the file the variable should be archived in 1083 945 !- pvarname : Name of the variable, short and easy to remember 1084 946 !- ptitle : Full name of the variable … … 1104 966 !- pzid : ID of the vertical axis to use. It has to have 1105 967 !- the size of the zoom. 1106 !- pnbbyt : Number of bytes on which to store in netCDF (Not opp.)968 !- xtype : External netCDF type (hist_r4/hist_r8) 1107 969 !- popp : Operation to be performed. The following options 1108 970 !- exist today : … … 1120 982 IMPLICIT NONE 1121 983 !- 1122 INTEGER,INTENT(IN) :: pfileid,pxsize,pysize,pzsize,pzid1123 INTEGER,INTENT(IN) :: par_oriz,par_szz, pnbbyt,phoriid984 INTEGER,INTENT(IN) :: idf,pxsize,pysize,pzsize,pzid 985 INTEGER,INTENT(IN) :: par_oriz,par_szz,xtype,phoriid 1124 986 CHARACTER(LEN=*),INTENT(IN) :: pvarname,punit,popp,ptitle 1125 987 REAL,INTENT(IN) :: pfreq_opp,pfreq_wrt 1126 988 REAL,DIMENSION(2),OPTIONAL,INTENT(IN) :: var_range 1127 !- 1128 INTEGER :: iv,i 989 CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: standard_name 990 !- 991 INTEGER :: iv 1129 992 CHARACTER(LEN=70) :: str70,str71,str72 1130 993 CHARACTER(LEN=20) :: tmp_name 1131 994 CHARACTER(LEN=40) :: str40 1132 995 CHARACTER(LEN=10) :: str10 1133 CHARACTER(LEN=80) :: tmp_str801134 CHARACTER(LEN=7) :: tmp_topp,tmp_sopp(nbopp_max)1135 996 CHARACTER(LEN=120) :: ex_topps 1136 REAL :: tmp_scal(nbopp_max),un_an,un_jour,test_fopp,test_fwrt997 REAL :: un_an,un_jour,test_fopp,test_fwrt 1137 998 INTEGER :: pos,buff_sz 1138 999 LOGICAL :: l_dbg … … 1142 1003 ex_topps = 'ave, inst, t_min, t_max, t_sum, once, never, l_max, l_min' 1143 1004 !- 1144 nb_var(pfileid) = nb_var(pfileid)+11145 iv = nb_var(pfileid)1005 W_F(idf)%n_var = W_F(idf)%n_var+1 1006 iv = W_F(idf)%n_var 1146 1007 !- 1147 1008 IF (iv > nb_var_max) THEN … … 1158 1019 !- 1159 1020 IF (iv > 1) THEN 1160 CALL find_str ( name(pfileid,1:iv-1),pvarname,pos)1021 CALL find_str (W_F(idf)%W_V(1:iv-1)%v_name,pvarname,pos) 1161 1022 ELSE 1162 1023 pos = 0 … … 1166 1027 str70 = "Variable already exists" 1167 1028 WRITE(str71,'("Check variable ",a," in file",I3)') & 1168 & TRIM(pvarname), pfileid1029 & TRIM(pvarname),idf 1169 1030 str72 = "Can also be a wrong file ID in another declaration" 1170 1031 CALL ipslerr (3,"histdef",str70,str71,str72) 1171 1032 ENDIF 1172 1033 !- 1173 name(pfileid,iv) = pvarname 1174 title(pfileid,iv) = ptitle 1175 unit_name(pfileid,iv) = punit 1176 tmp_name = name(pfileid,iv) 1034 W_F(idf)%W_V(iv)%v_name = pvarname 1035 W_F(idf)%W_V(iv)%title = ptitle 1036 W_F(idf)%W_V(iv)%unit_name = punit 1037 IF (PRESENT(standard_name)) THEN 1038 W_F(idf)%W_V(iv)%std_name = standard_name 1039 ELSE 1040 W_F(idf)%W_V(iv)%std_name = ptitle 1041 ENDIF 1042 tmp_name = W_F(idf)%W_V(iv)%v_name 1177 1043 !- 1178 1044 ! 1.1 decode the operations 1179 1045 !- 1180 fullop(pfileid,iv) = popp 1181 tmp_str80 = popp 1046 W_F(idf)%W_V(iv)%fullop = popp 1182 1047 CALL buildop & 1183 & (tmp_str80,ex_topps,tmp_topp,nbopp_max,missing_val, & 1184 & tmp_sopp,tmp_scal,nbopp(pfileid,iv)) 1185 !- 1186 topp(pfileid,iv) = tmp_topp 1187 DO i=1,nbopp(pfileid,iv) 1188 sopps(pfileid,iv,i) = tmp_sopp(i) 1189 scal(pfileid,iv,i) = tmp_scal(i) 1190 ENDDO 1048 & (TRIM(popp),ex_topps,W_F(idf)%W_V(iv)%topp,missing_val, & 1049 & W_F(idf)%W_V(iv)%sopp,W_F(idf)%W_V(iv)%scal, & 1050 & W_F(idf)%W_V(iv)%nbopp) 1191 1051 !- 1192 1052 ! 1.2 If we have an even number of operations 1193 1053 ! then we need to add identity 1194 1054 !- 1195 IF (2*INT(nbopp(pfileid,iv)/2.0) == nbopp(pfileid,iv)) THEN 1196 nbopp(pfileid,iv) = nbopp(pfileid,iv)+1 1197 sopps(pfileid,iv,nbopp(pfileid,iv)) = 'ident' 1198 scal(pfileid,iv,nbopp(pfileid,iv)) = missing_val 1055 IF ( MOD(W_F(idf)%W_V(iv)%nbopp,2) == 0) THEN 1056 W_F(idf)%W_V(iv)%nbopp = W_F(idf)%W_V(iv)%nbopp+1 1057 W_F(idf)%W_V(iv)%sopp(W_F(idf)%W_V(iv)%nbopp) = 'ident' 1058 W_F(idf)%W_V(iv)%scal(W_F(idf)%W_V(iv)%nbopp) = missing_val 1059 ENDIF 1060 !- 1061 ! 1.3 External type of the variable 1062 !- 1063 IF (xtype == hist_r8) THEN 1064 W_F(idf)%W_V(iv)%v_typ = hist_r8 1065 ELSE 1066 W_F(idf)%W_V(iv)%v_typ = hist_r4 1199 1067 ENDIF 1200 1068 !- 1201 1069 ! 2.0 Put the size of the variable in the common and check 1202 1070 !- 1203 IF (l_dbg) & 1204 & WRITE(*,*) "histdef : 2.0",pfileid,iv,nbopp(pfileid,iv), & 1205 & sopps(pfileid,iv,1:nbopp(pfileid,iv)), & 1206 & scal(pfileid,iv,1:nbopp(pfileid,iv)) 1207 !- 1208 scsize(pfileid,iv,1:3) = (/ pxsize,pysize,pzsize /) 1209 !- 1210 zorig(pfileid,iv,1:3) = & 1211 & (/ slab_ori(pfileid,1),slab_ori(pfileid,2),par_oriz /) 1212 !- 1213 zsize(pfileid,iv,1:3) = & 1214 & (/ slab_sz(pfileid,1),slab_sz(pfileid,2),par_szz /) 1215 !- 1216 ! Is the size of the full array the same as that of the coordinates ? 1217 !- 1218 IF ( (pxsize > full_size(pfileid,1)) & 1219 & .OR.(pysize > full_size(pfileid,2)) ) THEN 1071 IF (l_dbg) THEN 1072 WRITE(*,*) "histdef : 2.0",idf,iv,W_F(idf)%W_V(iv)%nbopp, & 1073 & W_F(idf)%W_V(iv)%sopp(1:W_F(idf)%W_V(iv)%nbopp), & 1074 & W_F(idf)%W_V(iv)%scal(1:W_F(idf)%W_V(iv)%nbopp) 1075 ENDIF 1076 !- 1077 W_F(idf)%W_V(iv)%scsize(1:3) = (/ pxsize,pysize,pzsize /) 1078 W_F(idf)%W_V(iv)%zorig(1:3) = & 1079 & (/ W_F(idf)%slab_ori(1),W_F(idf)%slab_ori(2),par_oriz /) 1080 W_F(idf)%W_V(iv)%zsize(1:3) = & 1081 & (/ W_F(idf)%slab_siz(1),W_F(idf)%slab_siz(2),par_szz /) 1082 !- 1083 ! Is the size of the full array the same as that of the coordinates ? 1084 !- 1085 IF ( (pxsize > W_F(idf)%full_size(1)) & 1086 & .OR.(pysize > W_F(idf)%full_size(2)) ) THEN 1220 1087 !- 1221 1088 str70 = "The size of the variable is different "// & 1222 1089 & "from the one of the coordinates" 1223 1090 WRITE(str71,'("Size of coordinates :",2I4)') & 1224 & full_size(pfileid,1),full_size(pfileid,2)1091 & W_F(idf)%full_size(1),W_F(idf)%full_size(2) 1225 1092 WRITE(str72,'("Size declared for variable ",a," :",2I4)') & 1226 1093 & TRIM(tmp_name),pxsize,pysize … … 1228 1095 ENDIF 1229 1096 !- 1230 ! Is the size of the zoom smal er than the coordinates ?1231 !- 1232 IF ( ( full_size(pfileid,1) < slab_sz(pfileid,1)) &1233 & .OR.( full_size(pfileid,2) < slab_sz(pfileid,2)) ) THEN1097 ! Is the size of the zoom smaller than the coordinates ? 1098 !- 1099 IF ( (W_F(idf)%full_size(1) < W_F(idf)%slab_siz(1)) & 1100 & .OR.(W_F(idf)%full_size(2) < W_F(idf)%slab_siz(2)) ) THEN 1234 1101 str70 = & 1235 1102 & "Size of variable should be greater or equal to those of the zoom" 1236 1103 WRITE(str71,'("Size of XY zoom :",2I4)') & 1237 & slab_sz(pfileid,1),slab_sz(pfileid,1)1238 WRITE(str72,'("Size declared for variable ", a," :",2I4)') &1104 & W_F(idf)%slab_siz(1),W_F(idf)%slab_siz(2) 1105 WRITE(str72,'("Size declared for variable ",A," :",2I4)') & 1239 1106 & TRIM(tmp_name),pxsize,pysize 1240 1107 CALL ipslerr (3,"histdef",str70,str71,str72) … … 1244 1111 ! and a fall back onto the default grid 1245 1112 !- 1246 IF ( (phoriid > 0).AND.(phoriid <= nb_hax(pfileid)) ) THEN1247 var_haxid(pfileid,iv)= phoriid1113 IF ( (phoriid > 0).AND.(phoriid <= W_F(idf)%n_hax) ) THEN 1114 W_F(idf)%W_V(iv)%h_axid = phoriid 1248 1115 ELSE 1249 var_haxid(pfileid,iv)= 11116 W_F(idf)%W_V(iv)%h_axid = 1 1250 1117 CALL ipslerr (2,"histdef", & 1251 1118 & 'We use the default grid for variable as an invalide',& … … 1259 1126 !-- Does the vertical coordinate exist ? 1260 1127 !- 1261 IF (pzid > nb_zax(pfileid)) THEN1128 IF (pzid > W_F(idf)%n_zax) THEN 1262 1129 WRITE(str70, & 1263 & '("The vertical coordinate chosen for variable ", a)') &1130 & '("The vertical coordinate chosen for variable ",A)') & 1264 1131 & TRIM(tmp_name) 1265 1132 str71 = " Does not exist." … … 1269 1136 !-- Is the vertical size of the variable equal to that of the axis ? 1270 1137 !- 1271 IF (par_szz /= zax_size(pfileid,pzid)) THEN1138 IF (par_szz /= W_F(idf)%zax_size(pzid)) THEN 1272 1139 str70 = "The size of the zoom does not correspond "// & 1273 1140 & "to the size of the chosen vertical axis" 1274 1141 WRITE(str71,'("Size of zoom in z :",I4)') par_szz 1275 1142 WRITE(str72,'("Size declared for axis ",A," :",I4)') & 1276 & TRIM( zax_name(pfileid,pzid)),zax_size(pfileid,pzid)1143 & TRIM(W_F(idf)%zax_name(pzid)),W_F(idf)%zax_size(pzid) 1277 1144 CALL ipslerr (3,"histdef",str70,str71,str72) 1278 1145 ENDIF 1279 1146 !- 1280 !-- Is the zoom smal er that the total size of the variable ?1147 !-- Is the zoom smaller that the total size of the variable ? 1281 1148 !- 1282 1149 IF (pzsize < par_szz) THEN … … 1288 1155 CALL ipslerr (3,"histdef",str70,str71,str72) 1289 1156 ENDIF 1290 var_zaxid(pfileid,iv)= pzid1157 W_F(idf)%W_V(iv)%z_axid = pzid 1291 1158 ELSE 1292 var_zaxid(pfileid,iv) = -99 1293 ENDIF 1294 !- 1295 ! 3.0 Determine the position of the variable in the buffer 1296 ! If it is instantaneous output then we do not use the buffer 1297 !- 1298 IF (l_dbg) WRITE(*,*) "histdef : 3.0" 1299 !- 1300 ! 3.1 We get the size of the arrays histwrite will get and check 1301 ! that they fit into the tmp_buffer 1302 !- 1303 buff_sz = zsize(pfileid,iv,1)*zsize(pfileid,iv,2)*zsize(pfileid,iv,3) 1304 !- 1305 ! 3.2 move the pointer of the buffer array for operation 1306 ! which need bufferisation 1307 !- 1308 IF ( (TRIM(tmp_topp) /= "inst") & 1309 & .AND.(TRIM(tmp_topp) /= "once") & 1310 & .AND.(TRIM(tmp_topp) /= "never") )THEN 1311 point(pfileid,iv) = buff_pos+1 1312 buff_pos = buff_pos+buff_sz 1159 W_F(idf)%W_V(iv)%z_axid = -99 1160 ENDIF 1161 !- 1162 ! 3.0 We get the size of the arrays histwrite will get 1163 ! and eventually allocate the time_buffer 1164 !- 1165 IF (l_dbg) THEN 1166 WRITE(*,*) "histdef : 3.0" 1167 ENDIF 1168 !- 1169 buff_sz = W_F(idf)%W_V(iv)%zsize(1) & 1170 & *W_F(idf)%W_V(iv)%zsize(2) & 1171 & *W_F(idf)%W_V(iv)%zsize(3) 1172 !- 1173 IF ( (TRIM(W_F(idf)%W_V(iv)%topp) /= "inst") & 1174 & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= "once") & 1175 & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= "never") )THEN 1176 ALLOCATE(W_F(idf)%W_V(iv)%t_bf(buff_sz)) 1177 W_F(idf)%W_V(iv)%t_bf(:) = 0. 1313 1178 IF (l_dbg) THEN 1314 WRITE(*,*) "histdef : 3. 2 bufpos for iv = ",iv, &1315 & " pfileid = ",pfileid," is = ",point(pfileid,iv)1179 WRITE(*,*) "histdef : 3.0 allocating time_buffer for", & 1180 & " idf = ",idf," iv = ",iv," size = ",buff_sz 1316 1181 ENDIF 1317 1182 ENDIF … … 1324 1189 IF (l_dbg) WRITE(*,*) "histdef : 4.0" 1325 1190 !- 1326 freq_opp(pfileid,iv)= pfreq_opp1327 freq_wrt(pfileid,iv)= pfreq_wrt1191 W_F(idf)%W_V(iv)%freq_opp = pfreq_opp 1192 W_F(idf)%W_V(iv)%freq_wrt = pfreq_wrt 1328 1193 !- 1329 1194 CALL ioget_calendar(un_an,un_jour) … … 1343 1208 ! 4.1 Frequency of operations and output should be larger than deltat ! 1344 1209 !- 1345 IF (test_fopp < deltat(pfileid)) THEN1210 IF (test_fopp < W_F(idf)%deltat) THEN 1346 1211 str70 = 'Frequency of operations should be larger than deltat' 1347 1212 WRITE(str71,'("It is not the case for variable ",a," :",F10.4)') & … … 1351 1216 CALL ipslerr (2,"histdef",str70,str71,str72) 1352 1217 !- 1353 freq_opp(pfileid,iv) = deltat(pfileid)1354 ENDIF 1355 !- 1356 IF (test_fwrt < deltat(pfileid)) THEN1218 W_F(idf)%W_V(iv)%freq_opp = W_F(idf)%deltat 1219 ENDIF 1220 !- 1221 IF (test_fwrt < W_F(idf)%deltat) THEN 1357 1222 str70 = 'Frequency of output should be larger than deltat' 1358 1223 WRITE(str71,'("It is not the case for variable ",a," :",F10.4)') & … … 1362 1227 CALL ipslerr (2,"histdef",str70,str71,str72) 1363 1228 !- 1364 freq_wrt(pfileid,iv) = deltat(pfileid)1229 W_F(idf)%W_V(iv)%freq_wrt = W_F(idf)%deltat 1365 1230 ENDIF 1366 1231 !- … … 1368 1233 ! its compaticility with the choice of frequencies 1369 1234 !- 1370 IF (TRIM( tmp_topp) == "inst") THEN1235 IF (TRIM(W_F(idf)%W_V(iv)%topp) == "inst") THEN 1371 1236 IF (test_fopp /= test_fwrt) THEN 1372 1237 str70 = 'For instantaneous output the frequency '// & … … 1378 1243 CALL ipslerr (2,"histdef",str70,str71,str72) 1379 1244 IF (test_fopp < test_fwrt) THEN 1380 freq_opp(pfileid,iv)= pfreq_opp1381 freq_wrt(pfileid,iv)= pfreq_opp1245 W_F(idf)%W_V(iv)%freq_opp = pfreq_opp 1246 W_F(idf)%W_V(iv)%freq_wrt = pfreq_opp 1382 1247 ELSE 1383 freq_opp(pfileid,iv)= pfreq_wrt1384 freq_wrt(pfileid,iv)= pfreq_wrt1248 W_F(idf)%W_V(iv)%freq_opp = pfreq_wrt 1249 W_F(idf)%W_V(iv)%freq_wrt = pfreq_wrt 1385 1250 ENDIF 1386 1251 ENDIF 1387 ELSE IF (INDEX(ex_topps,TRIM( tmp_topp)) > 0) THEN1252 ELSE IF (INDEX(ex_topps,TRIM(W_F(idf)%W_V(iv)%topp)) > 0) THEN 1388 1253 IF (test_fopp > test_fwrt) THEN 1389 1254 str70 = 'For averages the frequency of operations '// & 1390 &'should be smaller or equal'1255 & 'should be smaller or equal' 1391 1256 WRITE(str71, & 1392 1257 & '("to that of output. It is not the case for variable ",a)') & … … 1394 1259 str72 = 'PATCH : The output frequency is used for both' 1395 1260 CALL ipslerr (2,"histdef",str70,str71,str72) 1396 freq_opp(pfileid,iv)= pfreq_wrt1261 W_F(idf)%W_V(iv)%freq_opp = pfreq_wrt 1397 1262 ENDIF 1398 1263 ELSE 1399 WRITE (str70,'("Operation on variable ",a," is unknown")') & 1400 & TRIM(tmp_name) 1401 WRITE (str71,'("operation requested is :",a)') tmp_topp 1402 WRITE (str72,'("File ID :",I3)') pfileid 1264 WRITE (str70,'("Operation on variable ",A," is unknown")') & 1265 & TRIM(tmp_name) 1266 WRITE (str71,'("operation requested is :",A)') & 1267 & W_F(idf)%W_V(iv)%topp 1268 WRITE (str72,'("File ID :",I3)') idf 1403 1269 CALL ipslerr (3,"histdef",str70,str71,str72) 1404 1270 ENDIF … … 1408 1274 IF (l_dbg) WRITE(*,*) "histdef : 5.0" 1409 1275 !- 1410 hist_wrt_rng(pfileid,iv)= (PRESENT(var_range))1411 IF ( hist_wrt_rng(pfileid,iv)) THEN1412 hist_calc_rng(pfileid,iv)= (var_range(1) > var_range(2))1413 IF ( hist_calc_rng(pfileid,iv)) THEN1414 hist_minmax(pfileid,iv,1:2) = &1276 W_F(idf)%W_V(iv)%hist_wrt_rng = (PRESENT(var_range)) 1277 IF (W_F(idf)%W_V(iv)%hist_wrt_rng) THEN 1278 W_F(idf)%W_V(iv)%hist_calc_rng = (var_range(1) > var_range(2)) 1279 IF (W_F(idf)%W_V(iv)%hist_calc_rng) THEN 1280 W_F(idf)%W_V(iv)%hist_minmax(1:2) = & 1415 1281 & (/ ABS(missing_val),-ABS(missing_val) /) 1416 1282 ELSE 1417 hist_minmax(pfileid,iv,1:2) = var_range(1:2)1418 ENDIF 1419 ENDIF 1420 !- 1421 ! - freq_opp( pfileid,iv)/2./deltat(pfileid)1422 last_opp(pfileid,iv) = itau0(pfileid)1423 ! - freq_wrt( pfileid,iv)/2./deltat(pfileid)1424 last_wrt(pfileid,iv) = itau0(pfileid)1425 ! - freq_opp( pfileid,iv)/2./deltat(pfileid)1426 last_opp_chk(pfileid,iv) = itau0(pfileid)1427 ! - freq_wrt( pfileid,iv)/2./deltat(pfileid)1428 last_wrt_chk(pfileid,iv) = itau0(pfileid)1429 nb_opp(pfileid,iv)= 01430 nb_wrt(pfileid,iv)= 01283 W_F(idf)%W_V(iv)%hist_minmax(1:2) = var_range(1:2) 1284 ENDIF 1285 ENDIF 1286 !- 1287 ! - freq_opp(idf,iv)/2./deltat(idf) 1288 W_F(idf)%W_V(iv)%last_opp = W_F(idf)%itau0 1289 ! - freq_wrt(idf,iv)/2./deltat(idf) 1290 W_F(idf)%W_V(iv)%last_wrt = W_F(idf)%itau0 1291 ! - freq_opp(idf,iv)/2./deltat(idf) 1292 W_F(idf)%W_V(iv)%last_opp_chk = W_F(idf)%itau0 1293 ! - freq_wrt(idf,iv)/2./deltat(idf) 1294 W_F(idf)%W_V(iv)%last_wrt_chk = W_F(idf)%itau0 1295 W_F(idf)%W_V(iv)%nb_opp = 0 1296 W_F(idf)%W_V(iv)%nb_wrt = 0 1431 1297 !- 1432 1298 ! 6.0 Get the time axis for this variable … … 1434 1300 IF (l_dbg) WRITE(*,*) "histdef : 6.0" 1435 1301 !- 1436 IF (freq_wrt(pfileid,iv) > 0) THEN 1437 WRITE(str10,'(I8.8)') INT(freq_wrt(pfileid,iv)) 1438 str40 = TRIM(tmp_topp)//"_"//TRIM(str10) 1302 ! No time axis for once, l_max, l_min or never operation 1303 !- 1304 IF ( (TRIM(W_F(idf)%W_V(iv)%topp) /= 'once') & 1305 & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= 'never') & 1306 & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= 'l_max') & 1307 & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= 'l_min') ) THEN 1308 IF (TRIM(W_F(idf)%W_V(iv)%topp) == 'inst') THEN 1309 str10 = 't_inst_' 1310 ELSE 1311 str10 = 't_op_' 1312 ENDIF 1313 IF (W_F(idf)%W_V(iv)%freq_wrt > 0) THEN 1314 WRITE (UNIT=str40,FMT='(A,I8.8)') & 1315 & TRIM(str10),INT(W_F(idf)%W_V(iv)%freq_wrt) 1316 ELSE 1317 WRITE (UNIT=str40,FMT='(A,I2.2,"month")') & 1318 & TRIM(str10),ABS(INT(W_F(idf)%W_V(iv)%freq_wrt)) 1319 ENDIF 1320 CALL find_str (W_F(idf)%W_V(1:W_F(idf)%n_tax)%tax_name,str40,pos) 1321 IF (pos < 0) THEN 1322 W_F(idf)%n_tax = W_F(idf)%n_tax+1 1323 W_F(idf)%W_V(iv)%l_bnd = & 1324 & (TRIM(W_F(idf)%W_V(iv)%topp) /= 'inst') 1325 W_F(idf)%W_V(W_F(idf)%n_tax)%tax_name = str40 1326 W_F(idf)%W_V(W_F(idf)%n_tax)%tax_last = 0 1327 W_F(idf)%W_V(iv)%t_axid = W_F(idf)%n_tax 1328 ELSE 1329 W_F(idf)%W_V(iv)%t_axid = pos 1330 ENDIF 1439 1331 ELSE 1440 WRITE(str10,'(I2.2,"month")') ABS(INT(freq_wrt(pfileid,iv))) 1441 str40 = TRIM(tmp_topp)//"_"//TRIM(str10) 1442 ENDIF 1443 CALL find_str (tax_name(pfileid,1:nb_tax(pfileid)),str40,pos) 1444 !- 1445 ! No time axis for once, l_max, l_min or never operation 1446 !- 1447 IF ( (TRIM(tmp_topp) /= 'once') & 1448 & .AND.(TRIM(tmp_topp) /= 'never') & 1449 & .AND.(TRIM(tmp_topp) /= 'l_max') & 1450 & .AND.(TRIM(tmp_topp) /= 'l_min') ) THEN 1451 IF (pos < 0) THEN 1452 nb_tax(pfileid) = nb_tax(pfileid)+1 1453 tax_name(pfileid,nb_tax(pfileid)) = str40 1454 tax_last(pfileid,nb_tax(pfileid)) = 0 1455 var_axid(pfileid,iv) = nb_tax(pfileid) 1456 ELSE 1457 var_axid(pfileid,iv) = pos 1458 ENDIF 1459 ELSE 1460 IF (l_dbg) WRITE(*,*) "histdef : 7.0 ",TRIM(tmp_topp),'----' 1461 var_axid(pfileid,iv) = -99 1332 IF (l_dbg) THEN 1333 WRITE(*,*) "histdef : 7.0 ",TRIM(W_F(idf)%W_V(iv)%topp),'----' 1334 ENDIF 1335 W_F(idf)%W_V(iv)%t_axid = -99 1462 1336 ENDIF 1463 1337 !- … … 1465 1339 ! for never or once operation 1466 1340 !- 1467 IF ( (TRIM( tmp_topp) == 'once') &1468 & .OR.(TRIM( tmp_topp) == 'never') ) THEN1469 freq_opp(pfileid,iv)= 0.1470 freq_wrt(pfileid,iv)= 0.1341 IF ( (TRIM(W_F(idf)%W_V(iv)%topp) == 'once') & 1342 & .OR.(TRIM(W_F(idf)%W_V(iv)%topp) == 'never') ) THEN 1343 W_F(idf)%W_V(iv)%freq_opp = 0. 1344 W_F(idf)%W_V(iv)%freq_wrt = 0. 1471 1345 ENDIF 1472 1346 !--------------------- 1473 1347 END SUBROUTINE histdef 1474 1348 !=== 1475 SUBROUTINE histend ( pfileid)1349 SUBROUTINE histend (idf) 1476 1350 !--------------------------------------------------------------------- 1477 1351 !- This subroutine end the decalaration of variables and sets the … … 1480 1354 !- INPUT 1481 1355 !- 1482 !- pfileid: ID of the file to be worked on1356 !- idf : ID of the file to be worked on 1483 1357 !- 1484 1358 !- VERSION … … 1487 1361 IMPLICIT NONE 1488 1362 !- 1489 INTEGER,INTENT(IN) :: pfileid1490 !- 1491 INTEGER :: n cid,ncvarid,iret,ndim,iv,itx,ziv,itax,dim_cnt1363 INTEGER,INTENT(IN) :: idf 1364 !- 1365 INTEGER :: nfid,nvid,iret,ndim,iv,itx,ziv,itax,dim_cnt 1492 1366 INTEGER,DIMENSION(4) :: dims 1493 1367 INTEGER :: year,month,day,hours,minutes … … 1495 1369 REAL :: rtime0 1496 1370 CHARACTER(LEN=30) :: str30 1371 CHARACTER(LEN=35) :: str35 1497 1372 CHARACTER(LEN=120) :: assoc 1498 1373 CHARACTER(LEN=70) :: str70 … … 1501 1376 & 'JUL','AUG','SEP','OCT','NOV','DEC' /) 1502 1377 CHARACTER(LEN=7) :: tmp_opp 1378 LOGICAL :: l_b 1503 1379 LOGICAL :: l_dbg 1504 1380 !--------------------------------------------------------------------- 1505 1381 CALL ipsldbg (old_status=l_dbg) 1506 1382 !- 1507 n cid = ncdf_ids(pfileid)1383 nfid = W_F(idf)%ncfid 1508 1384 !- 1509 1385 ! 1.0 Create the time axes 1510 1386 !- 1511 1387 IF (l_dbg) WRITE(*,*) "histend : 1.0" 1512 !--- 1513 iret = NF90_DEF_DIM (ncid,'time_counter',NF90_UNLIMITED,tid(pfileid)) 1514 !- 1515 ! 1.1 Define all the time axes needed for this file 1516 !- 1517 DO itx=1,nb_tax(pfileid) 1518 dims(1) = tid(pfileid) 1519 IF (nb_tax(pfileid) > 1) THEN 1520 str30 = "t_"//tax_name(pfileid,itx) 1388 !- 1389 ! 1.1 Define the time dimensions needed for this file 1390 !- 1391 iret = NF90_DEF_DIM (nfid,'time_counter', & 1392 & NF90_UNLIMITED,W_F(idf)%tid) 1393 DO iv=1,W_F(idf)%n_var 1394 IF (W_F(idf)%W_V(iv)%l_bnd) THEN 1395 iret = NF90_DEF_DIM (nfid,'tbnds',2,W_F(idf)%bid) 1396 EXIT 1397 ENDIF 1398 ENDDO 1399 !- 1400 ! 1.2 Define all the time axes needed for this file 1401 !- 1402 DO itx=1,W_F(idf)%n_tax 1403 dims(1) = W_F(idf)%tid 1404 l_b = (INDEX(W_F(idf)%W_V(itx)%tax_name,"t_op_") == 1) 1405 IF (itx > 1) THEN 1406 str30 = W_F(idf)%W_V(itx)%tax_name 1521 1407 ELSE 1522 1408 str30 = "time_counter" 1523 1409 ENDIF 1524 iret = NF90_DEF_VAR (ncid,str30,NF90_DOUBLE, & 1525 & dims(1),tdimid(pfileid,itx)) 1526 IF (nb_tax(pfileid) <= 1) THEN 1527 iret = NF90_PUT_ATT (ncid,tdimid(pfileid,itx),'axis',"T") 1528 ENDIF 1529 iret = NF90_PUT_ATT (ncid,tdimid(pfileid,itx),'standard_name',"time") 1410 IF (l_b) THEN 1411 str35 = TRIM(str30)//'_bnds' 1412 ENDIF 1413 iret = NF90_DEF_VAR (nfid,TRIM(str30),NF90_REAL8, & 1414 & dims(1),W_F(idf)%W_V(itx)%tdimid) 1415 IF (itx <= 1) THEN 1416 iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid,'axis',"T") 1417 ENDIF 1418 iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & 1419 & 'standard_name',"time") 1530 1420 !--- 1531 1421 ! To transform the current itau into a real date and take it … … 1535 1425 ! if there is a ioconf routine to control it. 1536 1426 !--- 1537 !-- rtime0 = itau2date(itau0( pfileid),date0(pfileid),deltat(pfileid))1538 rtime0 = date0(pfileid)1427 !-- rtime0 = itau2date(itau0(idf),date0(idf),deltat(idf)) 1428 rtime0 = W_F(idf)%date0 1539 1429 !- 1540 1430 CALL ju2ymds(rtime0,year,month,day,sec) … … 1553 1443 & FMT='(A,I4.4,"-",I2.2,"-",I2.2," ",I2.2,":",I2.2,":",I2.2)') & 1554 1444 & 'seconds since ',year,month,day,hours,minutes,INT(sec) 1555 iret = NF90_PUT_ATT (ncid,tdimid(pfileid,itx),'units',TRIM(str70)) 1445 iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & 1446 & 'units',TRIM(str70)) 1556 1447 !- 1557 1448 CALL ioget_calendar (str30) 1558 iret = NF90_PUT_ATT (ncid,tdimid(pfileid,itx), & 1559 & 'calendar',TRIM(str30)) 1560 !- 1561 iret = NF90_PUT_ATT (ncid,tdimid(pfileid,itx),'title','Time') 1562 !- 1563 iret = NF90_PUT_ATT (ncid,tdimid(pfileid,itx), & 1564 & 'long_name','Time axis') 1449 iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & 1450 & 'calendar',TRIM(str30)) 1451 !- 1452 iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & 1453 & 'title','Time') 1454 !- 1455 iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & 1456 & 'long_name','Time axis') 1565 1457 !- 1566 1458 WRITE (UNIT=str70, & 1567 1459 & FMT='(" ",I4.4,"-",A3,"-",I2.2," ",I2.2,":",I2.2,":",I2.2)') & 1568 1460 & year,cal(month),day,hours,minutes,INT(sec) 1569 iret = NF90_PUT_ATT (ncid,tdimid(pfileid,itx), & 1570 & 'time_origin',TRIM(str70)) 1461 iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & 1462 & 'time_origin',TRIM(str70)) 1463 !--- 1464 IF (l_b) THEN 1465 iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & 1466 & 'bounds',TRIM(str35)) 1467 dims(1:2) = (/ W_F(idf)%bid,W_F(idf)%tid /) 1468 iret = NF90_DEF_VAR (nfid,TRIM(str35),NF90_REAL8, & 1469 & dims(1:2),W_F(idf)%W_V(itx)%tbndid) 1470 ENDIF 1571 1471 ENDDO 1572 1472 !- … … 1575 1475 IF (l_dbg) WRITE(*,*) "histend : 2.0" 1576 1476 !- 1577 DO iv=1, nb_var(pfileid)1578 !--- 1579 itax = var_axid(pfileid,iv)1580 !--- 1581 IF ( regular(pfileid)) THEN1582 dims(1:2) = (/ xid(pfileid),yid(pfileid)/)1477 DO iv=1,W_F(idf)%n_var 1478 !--- 1479 itax = W_F(idf)%W_V(iv)%t_axid 1480 !--- 1481 IF (W_F(idf)%regular) THEN 1482 dims(1:2) = (/ W_F(idf)%xid,W_F(idf)%yid /) 1583 1483 dim_cnt = 2 1584 1484 ELSE 1585 dims(1) = xid(pfileid)1485 dims(1) = W_F(idf)%xid 1586 1486 dim_cnt = 1 1587 1487 ENDIF 1588 1488 !--- 1589 tmp_opp = topp(pfileid,iv)1590 ziv = var_zaxid(pfileid,iv)1489 tmp_opp = W_F(idf)%W_V(iv)%topp 1490 ziv = W_F(idf)%W_V(iv)%z_axid 1591 1491 !--- 1592 1492 ! 2.1 dimension of field … … 1598 1498 IF (ziv == -99) THEN 1599 1499 ndim = dim_cnt+1 1600 dims(dim_cnt+1:dim_cnt+2) = (/ tid(pfileid),0 /)1500 dims(dim_cnt+1:dim_cnt+2) = (/ W_F(idf)%tid,0 /) 1601 1501 ELSE 1602 1502 ndim = dim_cnt+2 1603 dims(dim_cnt+1:dim_cnt+2) = (/zax_ids(pfileid,ziv),tid(pfileid)/) 1503 dims(dim_cnt+1:dim_cnt+2) = & 1504 & (/ W_F(idf)%zax_ids(ziv),W_F(idf)%tid /) 1604 1505 ENDIF 1605 1506 ELSE … … 1609 1510 ELSE 1610 1511 ndim = dim_cnt+1 1611 dims(dim_cnt+1:dim_cnt+2) = (/ zax_ids(pfileid,ziv),0 /)1512 dims(dim_cnt+1:dim_cnt+2) = (/ W_F(idf)%zax_ids(ziv),0 /) 1612 1513 ENDIF 1613 1514 ENDIF 1614 1515 !- 1615 iret = NF90_DEF_VAR (n cid,TRIM(name(pfileid,iv)),NF90_FLOAT, &1616 & dims(1:ABS(ndim)),ncvarid)1617 !- 1618 ncvar_ids(pfileid,iv) = ncvarid1619 !- 1620 IF (LEN_TRIM( unit_name(pfileid,iv)) > 0) THEN1621 iret = NF90_PUT_ATT (n cid,ncvarid,'units', &1622 & TRIM( unit_name(pfileid,iv)))1516 iret = NF90_DEF_VAR (nfid,TRIM(W_F(idf)%W_V(iv)%v_name), & 1517 & W_F(idf)%W_V(iv)%v_typ,dims(1:ABS(ndim)),nvid) 1518 !- 1519 W_F(idf)%W_V(iv)%ncvid = nvid 1520 !- 1521 IF (LEN_TRIM(W_F(idf)%W_V(iv)%unit_name) > 0) THEN 1522 iret = NF90_PUT_ATT (nfid,nvid,'units', & 1523 & TRIM(W_F(idf)%W_V(iv)%unit_name)) 1623 1524 ENDIF 1624 iret = NF90_PUT_ATT (ncid,ncvarid,'standard_name', & 1625 & TRIM(title(pfileid,iv))) 1626 !- 1627 iret = NF90_PUT_ATT (ncid,ncvarid,'_FillValue', & 1628 & REAL(missing_val,KIND=4)) 1629 IF (hist_wrt_rng(pfileid,iv)) THEN 1630 iret = NF90_PUT_ATT (ncid,ncvarid,'valid_min', & 1631 & REAL(hist_minmax(pfileid,iv,1),KIND=4)) 1632 iret = NF90_PUT_ATT (ncid,ncvarid,'valid_max', & 1633 & REAL(hist_minmax(pfileid,iv,2),KIND=4)) 1525 iret = NF90_PUT_ATT (nfid,nvid,'standard_name', & 1526 & TRIM(W_F(idf)%W_V(iv)%std_name)) 1527 !- 1528 IF (W_F(idf)%W_V(iv)%v_typ == hist_r8) THEN 1529 iret = NF90_PUT_ATT (nfid,nvid,'_FillValue',NF90_FILL_REAL8) 1530 ELSE 1531 iret = NF90_PUT_ATT (nfid,nvid,'_FillValue',NF90_FILL_REAL4) 1634 1532 ENDIF 1635 iret = NF90_PUT_ATT (ncid,ncvarid,'long_name', & 1636 & TRIM(title(pfileid,iv))) 1637 iret = NF90_PUT_ATT (ncid,ncvarid,'online_operation', & 1638 & TRIM(fullop(pfileid,iv))) 1533 IF (W_F(idf)%W_V(iv)%hist_wrt_rng) THEN 1534 IF (W_F(idf)%W_V(iv)%v_typ == hist_r8) THEN 1535 iret = NF90_PUT_ATT (nfid,nvid,'valid_min', & 1536 & REAL(W_F(idf)%W_V(iv)%hist_minmax(1),KIND=8)) 1537 iret = NF90_PUT_ATT (nfid,nvid,'valid_max', & 1538 & REAL(W_F(idf)%W_V(iv)%hist_minmax(2),KIND=8)) 1539 ELSE 1540 iret = NF90_PUT_ATT (nfid,nvid,'valid_min', & 1541 & REAL(W_F(idf)%W_V(iv)%hist_minmax(1),KIND=4)) 1542 iret = NF90_PUT_ATT (nfid,nvid,'valid_max', & 1543 & REAL(W_F(idf)%W_V(iv)%hist_minmax(2),KIND=4)) 1544 ENDIF 1545 ENDIF 1546 iret = NF90_PUT_ATT (nfid,nvid,'long_name', & 1547 & TRIM(W_F(idf)%W_V(iv)%title)) 1548 iret = NF90_PUT_ATT (nfid,nvid,'online_operation', & 1549 & TRIM(W_F(idf)%W_V(iv)%fullop)) 1639 1550 !- 1640 1551 SELECT CASE(ndim) … … 1646 1557 END SELECT 1647 1558 !- 1648 assoc=TRIM( hax_name(pfileid,var_haxid(pfileid,iv),2))&1649 & //' '//TRIM( hax_name(pfileid,var_haxid(pfileid,iv),1))1650 !- 1651 ziv = var_zaxid(pfileid,iv)1559 assoc=TRIM(W_F(idf)%hax_name(W_F(idf)%W_V(iv)%h_axid,2)) & 1560 & //' '//TRIM(W_F(idf)%hax_name(W_F(idf)%W_V(iv)%h_axid,1)) 1561 !- 1562 ziv = W_F(idf)%W_V(iv)%z_axid 1652 1563 IF (ziv > 0) THEN 1653 str30 = zax_name(pfileid,ziv)1564 str30 = W_F(idf)%zax_name(ziv) 1654 1565 assoc = TRIM(str30)//' '//TRIM(assoc) 1655 1566 ENDIF 1656 1567 !- 1657 1568 IF (itax > 0) THEN 1658 IF ( nb_tax(pfileid)> 1) THEN1659 str30 = "t_"//tax_name(pfileid,itax)1569 IF (itax > 1) THEN 1570 str30 = W_F(idf)%W_V(itax)%tax_name 1660 1571 ELSE 1661 1572 str30 = "time_counter" … … 1665 1576 IF (l_dbg) THEN 1666 1577 WRITE(*,*) "histend : 2.0.n, freq_opp, freq_wrt", & 1667 & freq_opp(pfileid,iv),freq_wrt(pfileid,iv)1578 & W_F(idf)%W_V(iv)%freq_opp,W_F(idf)%W_V(iv)%freq_wrt 1668 1579 ENDIF 1669 1580 !- 1670 iret = NF90_PUT_ATT (n cid,ncvarid,'interval_operation', &1671 & REAL( freq_opp(pfileid,iv),KIND=4))1672 iret = NF90_PUT_ATT (n cid,ncvarid,'interval_write', &1673 & REAL( freq_wrt(pfileid,iv),KIND=4))1581 iret = NF90_PUT_ATT (nfid,nvid,'interval_operation', & 1582 & REAL(W_F(idf)%W_V(iv)%freq_opp,KIND=4)) 1583 iret = NF90_PUT_ATT (nfid,nvid,'interval_write', & 1584 & REAL(W_F(idf)%W_V(iv)%freq_wrt,KIND=4)) 1674 1585 ENDIF 1675 iret = NF90_PUT_ATT (n cid,ncvarid,'coordinates',TRIM(assoc))1586 iret = NF90_PUT_ATT (nfid,nvid,'coordinates',TRIM(assoc)) 1676 1587 ENDIF 1677 1588 ENDDO … … 1679 1590 ! 2.2 Add DOMAIN attributes if needed 1680 1591 !- 1681 IF ( dom_id_svg(pfileid)>= 0) THEN1682 CALL flio_dom_att (n cid,dom_id_svg(pfileid))1592 IF (W_F(idf)%dom_id_svg >= 0) THEN 1593 CALL flio_dom_att (nfid,W_F(idf)%dom_id_svg) 1683 1594 ENDIF 1684 1595 !- … … 1687 1598 IF (l_dbg) WRITE(*,*) "histend : 3.0" 1688 1599 !- 1689 iret = NF90_ENDDEF (n cid)1600 iret = NF90_ENDDEF (nfid) 1690 1601 !- 1691 1602 ! 4.0 Give some informations to the user … … 1693 1604 IF (l_dbg) WRITE(*,*) "histend : 4.0" 1694 1605 !- 1695 WRITE(str70,'("All variables have been initialized on file :",I3)') pfileid1606 WRITE(str70,'("All variables have been initialized on file :",I3)') idf 1696 1607 CALL ipslerr (1,'histend',str70,'',' ') 1697 1608 !--------------------- 1698 1609 END SUBROUTINE histend 1699 1610 !=== 1700 SUBROUTINE histwrite_r1d ( pfileid,pvarname,pitau,pdata,nbindex,nindex)1611 SUBROUTINE histwrite_r1d (idf,pvarname,pitau,pdata,nbindex,nindex) 1701 1612 !--------------------------------------------------------------------- 1702 1613 IMPLICIT NONE 1703 1614 !- 1704 INTEGER,INTENT(IN) :: pfileid,pitau,nbindex1615 INTEGER,INTENT(IN) :: idf,pitau,nbindex 1705 1616 INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex 1706 1617 REAL,DIMENSION(:),INTENT(IN) :: pdata 1707 1618 CHARACTER(LEN=*),INTENT(IN) :: pvarname 1708 1619 !--------------------------------------------------------------------- 1709 CALL histw_rnd ( pfileid,pvarname,pitau,nbindex,nindex,pdata_1d=pdata)1620 CALL histw_rnd (idf,pvarname,pitau,nbindex,nindex,pdata_1d=pdata) 1710 1621 !--------------------------- 1711 1622 END SUBROUTINE histwrite_r1d 1712 1623 !=== 1713 SUBROUTINE histwrite_r2d ( pfileid,pvarname,pitau,pdata,nbindex,nindex)1624 SUBROUTINE histwrite_r2d (idf,pvarname,pitau,pdata,nbindex,nindex) 1714 1625 !--------------------------------------------------------------------- 1715 1626 IMPLICIT NONE 1716 1627 !- 1717 INTEGER,INTENT(IN) :: pfileid,pitau,nbindex1628 INTEGER,INTENT(IN) :: idf,pitau,nbindex 1718 1629 INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex 1719 1630 REAL,DIMENSION(:,:),INTENT(IN) :: pdata 1720 1631 CHARACTER(LEN=*),INTENT(IN) :: pvarname 1721 1632 !--------------------------------------------------------------------- 1722 CALL histw_rnd ( pfileid,pvarname,pitau,nbindex,nindex,pdata_2d=pdata)1633 CALL histw_rnd (idf,pvarname,pitau,nbindex,nindex,pdata_2d=pdata) 1723 1634 !--------------------------- 1724 1635 END SUBROUTINE histwrite_r2d 1725 1636 !=== 1726 SUBROUTINE histwrite_r3d ( pfileid,pvarname,pitau,pdata,nbindex,nindex)1637 SUBROUTINE histwrite_r3d (idf,pvarname,pitau,pdata,nbindex,nindex) 1727 1638 !--------------------------------------------------------------------- 1728 1639 IMPLICIT NONE 1729 1640 !- 1730 INTEGER,INTENT(IN) :: pfileid,pitau,nbindex1641 INTEGER,INTENT(IN) :: idf,pitau,nbindex 1731 1642 INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex 1732 1643 REAL,DIMENSION(:,:,:),INTENT(IN) :: pdata 1733 1644 CHARACTER(LEN=*),INTENT(IN) :: pvarname 1734 1645 !--------------------------------------------------------------------- 1735 CALL histw_rnd ( pfileid,pvarname,pitau,nbindex,nindex,pdata_3d=pdata)1646 CALL histw_rnd (idf,pvarname,pitau,nbindex,nindex,pdata_3d=pdata) 1736 1647 !--------------------------- 1737 1648 END SUBROUTINE histwrite_r3d 1738 1649 !=== 1739 SUBROUTINE histw_rnd ( pfileid,pvarname,pitau,nbindex,nindex, &1650 SUBROUTINE histw_rnd (idf,pvarname,pitau,nbindex,nindex, & 1740 1651 & pdata_1d,pdata_2d,pdata_3d) 1741 1652 !--------------------------------------------------------------------- 1742 1653 IMPLICIT NONE 1743 1654 !- 1744 INTEGER,INTENT(IN) :: pfileid,pitau,nbindex1655 INTEGER,INTENT(IN) :: idf,pitau,nbindex 1745 1656 INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex 1746 1657 CHARACTER(LEN=*),INTENT(IN) :: pvarname … … 1750 1661 !- 1751 1662 LOGICAL :: do_oper,do_write,largebuf,l1d,l2d,l3d 1752 INTEGER :: varid,io,nbpt_out1663 INTEGER :: iv,io,nbpt_out 1753 1664 INTEGER :: nbpt_in1 1754 1665 INTEGER,DIMENSION(2) :: nbpt_in2 1755 1666 INTEGER,DIMENSION(3) :: nbpt_in3 1756 REAL,ALLOCATABLE,DIMENSION(:),SAVE :: buff_tmp 1757 INTEGER,SAVE :: buff_tmp_sz 1667 REAL,ALLOCATABLE,DIMENSION(:),SAVE :: tbf_1 1758 1668 CHARACTER(LEN=7) :: tmp_opp 1759 1669 CHARACTER(LEN=13) :: c_nam … … 1771 1681 ENDIF 1772 1682 !- 1683 IF (l_dbg) THEN 1684 WRITE(*,*) "histwrite : ",c_nam 1685 ENDIF 1686 !- 1773 1687 ! 1.0 Try to catch errors like specifying the wrong file ID. 1774 1688 ! Thanks Marine for showing us what errors users can make ! 1775 1689 !- 1776 IF ( ( pfileid < 1).OR.(pfileid > nb_files) ) THEN1690 IF ( (idf < 1).OR.(idf > nb_files_max) ) THEN 1777 1691 CALL ipslerr (3,"histwrite", & 1778 1692 & 'Illegal file ID in the histwrite of variable',pvarname,' ') … … 1781 1695 ! 1.1 Find the id of the variable to be written and the real time 1782 1696 !- 1783 CALL histvar_seq ( pfileid,pvarname,varid)1697 CALL histvar_seq (idf,pvarname,iv) 1784 1698 !- 1785 1699 ! 2.0 do nothing for never operation 1786 1700 !- 1787 tmp_opp = topp(pfileid,varid)1701 tmp_opp = W_F(idf)%W_V(iv)%topp 1788 1702 !- 1789 1703 IF (TRIM(tmp_opp) == "never") THEN 1790 last_opp_chk(pfileid,varid)= -991791 last_wrt_chk(pfileid,varid)= -991704 W_F(idf)%W_V(iv)%last_opp_chk = -99 1705 W_F(idf)%W_V(iv)%last_wrt_chk = -99 1792 1706 ENDIF 1793 1707 !- 1794 1708 ! 3.0 We check if we need to do an operation 1795 1709 !- 1796 IF ( last_opp_chk(pfileid,varid)== pitau) THEN1710 IF (W_F(idf)%W_V(iv)%last_opp_chk == pitau) THEN 1797 1711 CALL ipslerr (3,"histwrite", & 1798 1712 & 'This variable has already been analysed at the present', & … … 1801 1715 !- 1802 1716 CALL isittime & 1803 & (pitau,date0(pfileid),deltat(pfileid),freq_opp(pfileid,varid), & 1804 & last_opp(pfileid,varid),last_opp_chk(pfileid,varid),do_oper) 1717 & (pitau,W_F(idf)%date0,W_F(idf)%deltat, & 1718 & W_F(idf)%W_V(iv)%freq_opp, & 1719 & W_F(idf)%W_V(iv)%last_opp, & 1720 & W_F(idf)%W_V(iv)%last_opp_chk,do_oper) 1805 1721 !- 1806 1722 ! 4.0 We check if we need to write the data 1807 1723 !- 1808 IF ( last_wrt_chk(pfileid,varid)== pitau) THEN1724 IF (W_F(idf)%W_V(iv)%last_wrt_chk == pitau) THEN 1809 1725 CALL ipslerr (3,"histwrite", & 1810 & 'This variable has already been written for the present', &1811 & 'time step', TRIM(pvarname))1726 & 'This variable as already been written for the present', & 1727 & 'time step',' ') 1812 1728 ENDIF 1813 1729 !- 1814 1730 CALL isittime & 1815 & (pitau,date0(pfileid),deltat(pfileid),freq_wrt(pfileid,varid), & 1816 & last_wrt(pfileid,varid),last_wrt_chk(pfileid,varid),do_write) 1731 & (pitau,W_F(idf)%date0,W_F(idf)%deltat, & 1732 & W_F(idf)%W_V(iv)%freq_wrt, & 1733 & W_F(idf)%W_V(iv)%last_wrt, & 1734 & W_F(idf)%W_V(iv)%last_wrt_chk,do_write) 1817 1735 !- 1818 1736 ! 5.0 histwrite called … … 1822 1740 !-- 5.1 Get the sizes of the data we will handle 1823 1741 !- 1824 IF ( datasz_in(pfileid,varid,1) <= 0) THEN1742 IF (W_F(idf)%W_V(iv)%datasz_in(1) <= 0) THEN 1825 1743 !---- There is the risk here that the user has over-sized the array. 1826 1744 !---- But how can we catch this ? 1827 1745 !---- In the worst case we will do impossible operations 1828 1746 !---- on part of the data ! 1829 datasz_in(pfileid,varid,1:3) = -11747 W_F(idf)%W_V(iv)%datasz_in(1:3) = -1 1830 1748 IF (l1d) THEN 1831 datasz_in(pfileid,varid,1) = SIZE(pdata_1d)1749 W_F(idf)%W_V(iv)%datasz_in(1) = SIZE(pdata_1d) 1832 1750 ELSE IF (l2d) THEN 1833 datasz_in(pfileid,varid,1) = SIZE(pdata_2d,DIM=1)1834 datasz_in(pfileid,varid,2) = SIZE(pdata_2d,DIM=2)1751 W_F(idf)%W_V(iv)%datasz_in(1) = SIZE(pdata_2d,DIM=1) 1752 W_F(idf)%W_V(iv)%datasz_in(2) = SIZE(pdata_2d,DIM=2) 1835 1753 ELSE IF (l3d) THEN 1836 datasz_in(pfileid,varid,1) = SIZE(pdata_3d,DIM=1)1837 datasz_in(pfileid,varid,2) = SIZE(pdata_3d,DIM=2)1838 datasz_in(pfileid,varid,3) = SIZE(pdata_3d,DIM=3)1754 W_F(idf)%W_V(iv)%datasz_in(1) = SIZE(pdata_3d,DIM=1) 1755 W_F(idf)%W_V(iv)%datasz_in(2) = SIZE(pdata_3d,DIM=2) 1756 W_F(idf)%W_V(iv)%datasz_in(3) = SIZE(pdata_3d,DIM=3) 1839 1757 ENDIF 1840 1758 ENDIF … … 1842 1760 !-- 5.2 The maximum size of the data will give the size of the buffer 1843 1761 !- 1844 IF ( datasz_max(pfileid,varid)<= 0) THEN1762 IF (W_F(idf)%W_V(iv)%datasz_max <= 0) THEN 1845 1763 largebuf = .FALSE. 1846 DO io=1, nbopp(pfileid,varid)1847 IF (INDEX(fuchnbout, sopps(pfileid,varid,io)) > 0) THEN1764 DO io=1,W_F(idf)%W_V(iv)%nbopp 1765 IF (INDEX(fuchnbout,W_F(idf)%W_V(iv)%sopp(io)) > 0) THEN 1848 1766 largebuf = .TRUE. 1849 1767 ENDIF 1850 1768 ENDDO 1851 1769 IF (largebuf) THEN 1852 datasz_max(pfileid,varid)= &1853 & scsize(pfileid,varid,1) &1854 & * scsize(pfileid,varid,2) &1855 & * scsize(pfileid,varid,3)1770 W_F(idf)%W_V(iv)%datasz_max = & 1771 & W_F(idf)%W_V(iv)%scsize(1) & 1772 & *W_F(idf)%W_V(iv)%scsize(2) & 1773 & *W_F(idf)%W_V(iv)%scsize(3) 1856 1774 ELSE 1857 1775 IF (l1d) THEN 1858 datasz_max(pfileid,varid)= &1859 & datasz_in(pfileid,varid,1)1776 W_F(idf)%W_V(iv)%datasz_max = & 1777 & W_F(idf)%W_V(iv)%datasz_in(1) 1860 1778 ELSE IF (l2d) THEN 1861 datasz_max(pfileid,varid)= &1862 & datasz_in(pfileid,varid,1) &1863 & * datasz_in(pfileid,varid,2)1779 W_F(idf)%W_V(iv)%datasz_max = & 1780 & W_F(idf)%W_V(iv)%datasz_in(1) & 1781 & *W_F(idf)%W_V(iv)%datasz_in(2) 1864 1782 ELSE IF (l3d) THEN 1865 datasz_max(pfileid,varid)= &1866 & datasz_in(pfileid,varid,1) &1867 & * datasz_in(pfileid,varid,2) &1868 & * datasz_in(pfileid,varid,3)1783 W_F(idf)%W_V(iv)%datasz_max = & 1784 & W_F(idf)%W_V(iv)%datasz_in(1) & 1785 & *W_F(idf)%W_V(iv)%datasz_in(2) & 1786 & *W_F(idf)%W_V(iv)%datasz_in(3) 1869 1787 ENDIF 1870 1788 ENDIF 1871 1789 ENDIF 1872 1790 !- 1873 IF (.NOT.ALLOCATED( buff_tmp)) THEN1791 IF (.NOT.ALLOCATED(tbf_1)) THEN 1874 1792 IF (l_dbg) THEN 1875 1793 WRITE(*,*) & 1876 & c_nam//" : allocate buff_tmp for buff_sz= ", &1877 & datasz_max(pfileid,varid)1794 & c_nam//" : allocate tbf_1 for size = ", & 1795 & W_F(idf)%W_V(iv)%datasz_max 1878 1796 ENDIF 1879 ALLOCATE(buff_tmp(datasz_max(pfileid,varid))) 1880 buff_tmp_sz = datasz_max(pfileid,varid) 1881 ELSE IF (datasz_max(pfileid,varid) > buff_tmp_sz) THEN 1797 ALLOCATE(tbf_1(W_F(idf)%W_V(iv)%datasz_max)) 1798 ELSE IF (W_F(idf)%W_V(iv)%datasz_max > SIZE(tbf_1)) THEN 1882 1799 IF (l_dbg) THEN 1883 1800 WRITE(*,*) & 1884 & c_nam//" : re-allocate buff_tmp for buff_sz= ", &1885 & datasz_max(pfileid,varid)1801 & c_nam//" : re-allocate tbf_1 for size = ", & 1802 & W_F(idf)%W_V(iv)%datasz_max 1886 1803 ENDIF 1887 DEALLOCATE(buff_tmp) 1888 ALLOCATE(buff_tmp(datasz_max(pfileid,varid))) 1889 buff_tmp_sz = datasz_max(pfileid,varid) 1804 DEALLOCATE(tbf_1) 1805 ALLOCATE(tbf_1(W_F(idf)%W_V(iv)%datasz_max)) 1890 1806 ENDIF 1891 1807 !- … … 1894 1810 !-- of the data at the same time. This should speed up things. 1895 1811 !- 1896 nbpt_out = datasz_max(pfileid,varid)1812 nbpt_out = W_F(idf)%W_V(iv)%datasz_max 1897 1813 IF (l1d) THEN 1898 nbpt_in1 = datasz_in(pfileid,varid,1)1899 CALL mathop ( sopps(pfileid,varid,1),nbpt_in1,pdata_1d, &1814 nbpt_in1 = W_F(idf)%W_V(iv)%datasz_in(1) 1815 CALL mathop (W_F(idf)%W_V(iv)%sopp(1),nbpt_in1,pdata_1d, & 1900 1816 & missing_val,nbindex,nindex, & 1901 & scal(pfileid,varid,1),nbpt_out,buff_tmp)1817 & W_F(idf)%W_V(iv)%scal(1),nbpt_out,tbf_1) 1902 1818 ELSE IF (l2d) THEN 1903 nbpt_in2(1:2) = datasz_in(pfileid,varid,1:2)1904 CALL mathop ( sopps(pfileid,varid,1),nbpt_in2,pdata_2d, &1819 nbpt_in2(1:2) = W_F(idf)%W_V(iv)%datasz_in(1:2) 1820 CALL mathop (W_F(idf)%W_V(iv)%sopp(1),nbpt_in2,pdata_2d, & 1905 1821 & missing_val,nbindex,nindex, & 1906 & scal(pfileid,varid,1),nbpt_out,buff_tmp)1822 & W_F(idf)%W_V(iv)%scal(1),nbpt_out,tbf_1) 1907 1823 ELSE IF (l3d) THEN 1908 nbpt_in3(1:3) = datasz_in(pfileid,varid,1:3)1909 CALL mathop ( sopps(pfileid,varid,1),nbpt_in3,pdata_3d, &1824 nbpt_in3(1:3) = W_F(idf)%W_V(iv)%datasz_in(1:3) 1825 CALL mathop (W_F(idf)%W_V(iv)%sopp(1),nbpt_in3,pdata_3d, & 1910 1826 & missing_val,nbindex,nindex, & 1911 & scal(pfileid,varid,1),nbpt_out,buff_tmp)1912 ENDIF 1913 CALL histwrite_real ( pfileid,varid,pitau,nbpt_out, &1914 & buff_tmp,nbindex,nindex,do_oper,do_write)1827 & W_F(idf)%W_V(iv)%scal(1),nbpt_out,tbf_1) 1828 ENDIF 1829 CALL histwrite_real (idf,iv,pitau,nbpt_out, & 1830 & tbf_1,nbindex,nindex,do_oper,do_write) 1915 1831 ENDIF 1916 1832 !- … … 1918 1834 !- 1919 1835 IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN 1920 last_opp_chk(pfileid,varid)= pitau1921 last_wrt_chk(pfileid,varid)= pitau1836 W_F(idf)%W_V(iv)%last_opp_chk = pitau 1837 W_F(idf)%W_V(iv)%last_wrt_chk = pitau 1922 1838 ELSE 1923 last_opp_chk(pfileid,varid)= -991924 last_wrt_chk(pfileid,varid)= -991839 W_F(idf)%W_V(iv)%last_opp_chk = -99 1840 W_F(idf)%W_V(iv)%last_wrt_chk = -99 1925 1841 ENDIF 1926 1842 !----------------------- … … 1928 1844 !=== 1929 1845 SUBROUTINE histwrite_real & 1930 & ( pfileid,varid,pitau,nbdpt,buff_tmp,nbindex,nindex,do_oper,do_write)1846 & (idf,iv,pitau,nbdpt,tbf_1,nbindex,nindex,do_oper,do_write) 1931 1847 !--------------------------------------------------------------------- 1932 1848 !- This subroutine is internal and does the calculations and writing … … 1936 1852 IMPLICIT NONE 1937 1853 !- 1938 INTEGER,INTENT(IN) :: pfileid,pitau,varid, &1854 INTEGER,INTENT(IN) :: idf,pitau,iv, & 1939 1855 & nbindex,nindex(nbindex),nbdpt 1940 REAL,DIMENSION(:) :: buff_tmp1856 REAL,DIMENSION(:) :: tbf_1 1941 1857 LOGICAL,INTENT(IN) :: do_oper,do_write 1942 1858 !- 1943 INTEGER :: tsz,n cid,ncvarid,i,iret,ipt,itax,io,nbin,nbout1859 INTEGER :: tsz,nfid,nvid,iret,itax,io,nbin,nbout 1944 1860 INTEGER :: nx,ny,nz,ky,kz,kt,kc 1945 1861 INTEGER,DIMENSION(4) :: corner,edges … … 1947 1863 !- 1948 1864 REAL :: rtime 1865 REAL,DIMENSION(2) :: t_bnd 1949 1866 CHARACTER(LEN=7) :: tmp_opp 1950 REAL,ALLOCATABLE,DIMENSION(:),SAVE :: buff_tmp2,buffer_used 1951 INTEGER,SAVE :: buff_tmp2_sz,buffer_sz 1867 REAL,ALLOCATABLE,DIMENSION(:),SAVE :: tbf_2 1952 1868 LOGICAL :: l_dbg 1953 1869 !--------------------------------------------------------------------- … … 1955 1871 !- 1956 1872 IF (l_dbg) THEN 1957 WRITE(*,*) "histwrite 0.0 : VAR : ", name(pfileid,varid)1958 WRITE(*,*) "histwrite 0.0 : nbindex ,nindex :", &1959 & nbindex,nindex(1:MIN(3,nbindex)),'...',nindex(MAX(1,nbindex-3):nbindex)1873 WRITE(*,*) "histwrite 0.0 : VAR : ",W_F(idf)%W_V(iv)%v_name 1874 WRITE(*,*) "histwrite 0.0 : nbindex :",nbindex 1875 WRITE(*,*) "histwrite 0.0 : nindex :",nindex(1:MIN(3,nbindex)),'...' 1960 1876 ENDIF 1961 1877 !- 1962 1878 ! The sizes which can be encoutered 1963 1879 !- 1964 tsz = zsize(pfileid,varid,1) & 1965 & *zsize(pfileid,varid,2) & 1966 & *zsize(pfileid,varid,3) 1967 !- 1968 ! 1.0 We allocate the memory needed to store the data between write 1969 ! and the temporary space needed for operations. 1970 ! We have to keep precedent buffer if needed 1971 !- 1972 IF (.NOT. ALLOCATED(buffer)) THEN 1973 IF (l_dbg) WRITE(*,*) "histwrite_real 1.0 allocate buffer ",buff_pos 1974 ALLOCATE(buffer(buff_pos)) 1975 buffer_sz = buff_pos 1976 buffer(:)=0.0 1977 ELSE IF (buffer_sz < buff_pos) THEN 1880 tsz = W_F(idf)%W_V(iv)%zsize(1) & 1881 & *W_F(idf)%W_V(iv)%zsize(2) & 1882 & *W_F(idf)%W_V(iv)%zsize(3) 1883 !- 1884 ! 1.0 We allocate and the temporary space needed for operations. 1885 ! The buffers are only deallocated when more space is needed. 1886 ! This reduces the umber of allocates but increases memory needs. 1887 !- 1888 IF (.NOT.ALLOCATED(tbf_2)) THEN 1978 1889 IF (l_dbg) THEN 1979 WRITE(*,*) "histwrite_real 1.0.1 re-allocate buffer for ", & 1980 & buff_pos," instead of ",SIZE(buffer) 1981 ENDIF 1982 IF (SUM(buffer)/=0.0) THEN 1983 IF (l_dbg) WRITE (*,*) 'histwrite : buffer has been used. ', & 1984 & 'We have to save it before re-allocating.' 1985 ALLOCATE(buffer_used(buffer_sz)) 1986 buffer_used(:)=buffer(:) 1987 DEALLOCATE(buffer) 1988 ALLOCATE(buffer(buff_pos)) 1989 buffer_sz = buff_pos 1990 buffer(:)=0.0 1991 buffer(:SIZE(buffer_used))=buffer_used 1992 DEALLOCATE(buffer_used) 1993 ELSE 1994 IF (l_dbg) WRITE (*,*) 'histwrite : buffer has not been used. ', & 1995 & 'We have just to re-allocate it.' 1996 DEALLOCATE(buffer) 1997 ALLOCATE(buffer(buff_pos)) 1998 buffer_sz = buff_pos 1999 buffer(:)=0.0 2000 ENDIF 2001 ENDIF 2002 !- 2003 ! The buffers are only deallocated when more space is needed. This 2004 ! reduces the umber of allocates but increases memory needs. 2005 !- 2006 IF (.NOT.ALLOCATED(buff_tmp2)) THEN 1890 WRITE(*,*) "histwrite_real 1.1 allocate tbf_2 ",SIZE(tbf_1) 1891 ENDIF 1892 ALLOCATE(tbf_2(W_F(idf)%W_V(iv)%datasz_max)) 1893 ELSE IF (W_F(idf)%W_V(iv)%datasz_max > SIZE(tbf_2)) THEN 2007 1894 IF (l_dbg) THEN 2008 WRITE(*,*) "histwrite_real 1.1 allocate buff_tmp2 ",SIZE(buff_tmp) 2009 ENDIF 2010 ALLOCATE(buff_tmp2(datasz_max(pfileid,varid))) 2011 buff_tmp2_sz = datasz_max(pfileid,varid) 2012 ELSE IF (datasz_max(pfileid,varid) > buff_tmp2_sz) THEN 2013 IF (l_dbg) THEN 2014 WRITE(*,*) "histwrite_real 1.2 re-allocate buff_tmp2 : ", & 2015 & SIZE(buff_tmp)," instead of ",SIZE(buff_tmp2) 2016 ENDIF 2017 DEALLOCATE(buff_tmp2) 2018 ALLOCATE(buff_tmp2(datasz_max(pfileid,varid))) 2019 buff_tmp2_sz = datasz_max(pfileid,varid) 2020 ENDIF 2021 !- 2022 rtime = pitau * deltat(pfileid) 2023 tmp_opp = topp(pfileid,varid) 2024 !- 2025 ! 3.0 Do the operations or transfer the slab of data into buff_tmp 2026 !- 2027 IF (l_dbg) WRITE(*,*) "histwrite: 3.0",pfileid 1895 WRITE(*,*) "histwrite_real 1.2 re-allocate tbf_2 : ", & 1896 & SIZE(tbf_1)," instead of ",SIZE(tbf_2) 1897 ENDIF 1898 DEALLOCATE(tbf_2) 1899 ALLOCATE(tbf_2(W_F(idf)%W_V(iv)%datasz_max)) 1900 ENDIF 1901 !- 1902 rtime = pitau*W_F(idf)%deltat 1903 tmp_opp = W_F(idf)%W_V(iv)%topp 1904 !- 1905 ! 3.0 Do the operations or transfer the slab of data into tbf_1 1906 !- 1907 IF (l_dbg) THEN 1908 WRITE(*,*) "histwrite: 3.0",idf 1909 ENDIF 2028 1910 !- 2029 1911 ! 3.1 DO the Operations only if needed 2030 1912 !- 2031 1913 IF (do_oper) THEN 2032 i = pfileid2033 1914 nbout = nbdpt 2034 1915 !- … … 2036 1917 !-- we started in the interface routine 2037 1918 !- 2038 DO io = 2,nbopp(i,varid),21919 DO io=2,W_F(idf)%W_V(iv)%nbopp,2 2039 1920 nbin = nbout 2040 nbout = datasz_max(i,varid) 2041 CALL mathop(sopps(i,varid,io),nbin,buff_tmp,missing_val, & 2042 & nbindex,nindex,scal(i,varid,io),nbout,buff_tmp2) 1921 nbout = W_F(idf)%W_V(iv)%datasz_max 1922 CALL mathop(W_F(idf)%W_V(iv)%sopp(io),nbin,tbf_1, & 1923 & missing_val,nbindex,nindex,W_F(idf)%W_V(iv)%scal(io), & 1924 & nbout,tbf_2) 2043 1925 IF (l_dbg) THEN 2044 1926 WRITE(*,*) & 2045 & "histwrite: 3.4a nbout : ",nbin,nbout, sopps(i,varid,io)1927 & "histwrite: 3.4a nbout : ",nbin,nbout,W_F(idf)%W_V(iv)%sopp(io) 2046 1928 ENDIF 2047 1929 !- 2048 1930 nbin = nbout 2049 nbout = datasz_max(i,varid) 2050 CALL mathop(sopps(i,varid,io+1),nbin,buff_tmp2,missing_val, & 2051 & nbindex,nindex,scal(i,varid,io+1),nbout,buff_tmp) 1931 nbout = W_F(idf)%W_V(iv)%datasz_max 1932 CALL mathop(W_F(idf)%W_V(iv)%sopp(io+1),nbin,tbf_2, & 1933 & missing_val,nbindex,nindex,W_F(idf)%W_V(iv)%scal(io+1), & 1934 & nbout,tbf_1) 2052 1935 IF (l_dbg) THEN 2053 1936 WRITE(*,*) & 2054 & "histwrite: 3.4b nbout : ",nbin,nbout,sopps(i,varid,io+1)1937 & "histwrite: 3.4b nbout : ",nbin,nbout,W_F(idf)%W_V(iv)%sopp(io+1) 2055 1938 ENDIF 2056 1939 ENDDO … … 2060 1943 IF (l_dbg) THEN 2061 1944 WRITE(*,*) & 2062 & "histwrite: 3.5 size( buff_tmp) : ",SIZE(buff_tmp)1945 & "histwrite: 3.5 size(tbf_1) : ",SIZE(tbf_1) 2063 1946 WRITE(*,*) & 2064 & "histwrite: 3.5 slab in X :",zorig(i,varid,1),zsize(i,varid,1) 1947 & "histwrite: 3.5 slab in X :", & 1948 & W_F(idf)%W_V(iv)%zorig(1),W_F(idf)%W_V(iv)%zsize(1) 2065 1949 WRITE(*,*) & 2066 & "histwrite: 3.5 slab in Y :",zorig(i,varid,2),zsize(i,varid,2) 1950 & "histwrite: 3.5 slab in Y :", & 1951 & W_F(idf)%W_V(iv)%zorig(2),W_F(idf)%W_V(iv)%zsize(2) 2067 1952 WRITE(*,*) & 2068 & "histwrite: 3.5 slab in Z :",zorig(i,varid,3),zsize(i,varid,3) 1953 & "histwrite: 3.5 slab in Z :", & 1954 & W_F(idf)%W_V(iv)%zorig(3),W_F(idf)%W_V(iv)%zsize(3) 2069 1955 WRITE(*,*) & 2070 1956 & "histwrite: 3.5 slab of input:", & 2071 & scsize(i,varid,1),scsize(i,varid,2),scsize(i,varid,3) 1957 & W_F(idf)%W_V(iv)%scsize(1), & 1958 & W_F(idf)%W_V(iv)%scsize(2), & 1959 & W_F(idf)%W_V(iv)%scsize(3) 2072 1960 ENDIF 2073 1961 !--- 2074 1962 !-- We have to consider blocks of contiguous data 2075 1963 !--- 2076 nx=MAX(zsize(i,varid,1),1) 2077 ny=MAX(zsize(i,varid,2),1) 2078 nz=MAX(zsize(i,varid,3),1) 2079 IF ( (zorig(i,varid,1) == 1) & 2080 & .AND.(zsize(i,varid,1) == scsize(i,varid,1)) & 2081 & .AND.(zorig(i,varid,2) == 1) & 2082 & .AND.(zsize(i,varid,2) == scsize(i,varid,2))) THEN 2083 kt = (zorig(i,varid,3)-1)*nx*ny 2084 buff_tmp2(1:nx*ny*nz) = buff_tmp(kt+1:kt+nx*ny*nz) 2085 ELSEIF ( (zorig(i,varid,1) == 1) & 2086 & .AND.(zsize(i,varid,1) == scsize(i,varid,1))) THEN 1964 nx=MAX(W_F(idf)%W_V(iv)%zsize(1),1) 1965 ny=MAX(W_F(idf)%W_V(iv)%zsize(2),1) 1966 nz=MAX(W_F(idf)%W_V(iv)%zsize(3),1) 1967 IF ( (W_F(idf)%W_V(iv)%zorig(1) == 1) & 1968 & .AND.( W_F(idf)%W_V(iv)%zsize(1) & 1969 & == W_F(idf)%W_V(iv)%scsize(1)) & 1970 & .AND.(W_F(idf)%W_V(iv)%zorig(2) == 1) & 1971 & .AND.( W_F(idf)%W_V(iv)%zsize(2) & 1972 & == W_F(idf)%W_V(iv)%scsize(2))) THEN 1973 kt = (W_F(idf)%W_V(iv)%zorig(3)-1)*nx*ny 1974 tbf_2(1:nx*ny*nz) = tbf_1(kt+1:kt+nx*ny*nz) 1975 ELSEIF ( (W_F(idf)%W_V(iv)%zorig(1) == 1) & 1976 & .AND.( W_F(idf)%W_V(iv)%zsize(1) & 1977 & == W_F(idf)%W_V(iv)%scsize(1))) THEN 2087 1978 kc = -nx*ny 2088 DO kz= zorig(i,varid,3),zorig(i,varid,3)+nz-11979 DO kz=W_F(idf)%W_V(iv)%zorig(3),W_F(idf)%W_V(iv)%zorig(3)+nz-1 2089 1980 kc = kc+nx*ny 2090 kt = ((kz-1)*scsize(i,varid,2)+zorig(i,varid,2)-1)*nx 2091 buff_tmp2(kc+1:kc+nx*ny) = buff_tmp(kt+1:kt+nx*ny) 1981 kt = ( (kz-1)*W_F(idf)%W_V(iv)%scsize(2) & 1982 & +W_F(idf)%W_V(iv)%zorig(2)-1)*nx 1983 tbf_2(kc+1:kc+nx*ny) = tbf_1(kt+1:kt+nx*ny) 2092 1984 ENDDO 2093 1985 ELSE 2094 1986 kc = -nx 2095 DO kz= zorig(i,varid,3),zorig(i,varid,3)+nz-12096 DO ky= zorig(i,varid,2),zorig(i,varid,2)+ny-11987 DO kz=W_F(idf)%W_V(iv)%zorig(3),W_F(idf)%W_V(iv)%zorig(3)+nz-1 1988 DO ky=W_F(idf)%W_V(iv)%zorig(2),W_F(idf)%W_V(iv)%zorig(2)+ny-1 2097 1989 kc = kc+nx 2098 kt = ((kz-1)*scsize(i,varid,2)+ky-1)*scsize(i,varid,1) & 2099 & +zorig(i,varid,1)-1 2100 buff_tmp2(kc+1:kc+nx) = buff_tmp(kt+1:kt+nx) 1990 kt = ((kz-1)*W_F(idf)%W_V(iv)%scsize(2)+ky-1) & 1991 & *W_F(idf)%W_V(iv)%scsize(1) & 1992 & +W_F(idf)%W_V(iv)%zorig(1)-1 1993 tbf_2(kc+1:kc+nx) = tbf_1(kt+1:kt+nx) 2101 1994 ENDDO 2102 1995 ENDDO 2103 1996 ENDIF 2104 1997 !- 2105 !-- 4.0 Get the min and max of the field (buff_tmp) 2106 !- 2107 IF (l_dbg) WRITE(*,*) "histwrite: 4.0 buff_tmp",pfileid,varid, & 2108 & TRIM(tmp_opp),' ---- ',LEN_TRIM(tmp_opp),nbindex 2109 !- 2110 IF (hist_calc_rng(pfileid,varid)) THEN 2111 hist_minmax(pfileid,varid,1) = & 2112 & MIN(hist_minmax(pfileid,varid,1), & 2113 & MINVAL(buff_tmp2(1:tsz),MASK=buff_tmp2(1:tsz) /= missing_val)) 2114 hist_minmax(pfileid,varid,2) = & 2115 & MAX(hist_minmax(pfileid,varid,2), & 2116 & MAXVAL(buff_tmp2(1:tsz),MASK=buff_tmp2(1:tsz) /= missing_val)) 1998 !-- 4.0 Get the min and max of the field 1999 !- 2000 IF (l_dbg) THEN 2001 WRITE(*,*) "histwrite: 4.0 tbf_1",idf,iv, & 2002 & TRIM(tmp_opp),' ---- ',LEN_TRIM(tmp_opp),nbindex 2003 ENDIF 2004 !- 2005 IF (W_F(idf)%W_V(iv)%hist_calc_rng) THEN 2006 W_F(idf)%W_V(iv)%hist_minmax(1) = & 2007 & MIN(W_F(idf)%W_V(iv)%hist_minmax(1), & 2008 & MINVAL(tbf_2(1:tsz),MASK=tbf_2(1:tsz) /= missing_val)) 2009 W_F(idf)%W_V(iv)%hist_minmax(2) = & 2010 & MAX(W_F(idf)%W_V(iv)%hist_minmax(2), & 2011 & MAXVAL(tbf_2(1:tsz),MASK=tbf_2(1:tsz) /= missing_val)) 2117 2012 ENDIF 2118 2013 !- 2119 2014 !-- 5.0 Do the operations if needed. In the case of instantaneous 2120 !-- output we do not transfer to the buffer. 2121 !- 2122 IF (l_dbg) WRITE(*,*) "histwrite: 5.0",pfileid,"tsz :",tsz 2123 !- 2124 ipt = point(pfileid,varid) 2125 !- 2126 ! WRITE(*,*) 'OPE ipt, buffer :',pvarname,ipt,varid 2015 !-- output we do not transfer to the time_buffer. 2016 !- 2017 IF (l_dbg) THEN 2018 WRITE(*,*) "histwrite: 5.0 idf : ",idf," iv : ",iv," tsz : ",tsz 2019 ENDIF 2127 2020 !- 2128 2021 IF ( (TRIM(tmp_opp) /= "inst") & 2129 &.AND.(TRIM(tmp_opp) /= "once") ) THEN2130 CALL moycum(tmp_opp,tsz, buffer(ipt:), &2131 & buff_tmp2,nb_opp(pfileid,varid))2132 ENDIF 2133 !- 2134 last_opp(pfileid,varid)= pitau2135 nb_opp(pfileid,varid) = nb_opp(pfileid,varid)+12022 & .AND.(TRIM(tmp_opp) /= "once") ) THEN 2023 CALL moycum(tmp_opp,tsz,W_F(idf)%W_V(iv)%t_bf, & 2024 & tbf_2,W_F(idf)%W_V(iv)%nb_opp) 2025 ENDIF 2026 !- 2027 W_F(idf)%W_V(iv)%last_opp = pitau 2028 W_F(idf)%W_V(iv)%nb_opp = W_F(idf)%W_V(iv)%nb_opp+1 2136 2029 !- 2137 2030 ENDIF … … 2139 2032 ! 6.0 Write to file if needed 2140 2033 !- 2141 IF (l_dbg) WRITE(*,*) "histwrite: 6.0", pfileid2034 IF (l_dbg) WRITE(*,*) "histwrite: 6.0",idf 2142 2035 !- 2143 2036 IF (do_write) THEN 2144 2037 !- 2145 n cvarid = ncvar_ids(pfileid,varid)2146 n cid = ncdf_ids(pfileid)2038 nfid = W_F(idf)%ncfid 2039 nvid = W_F(idf)%W_V(iv)%ncvid 2147 2040 !- 2148 2041 !-- 6.1 Do the operations that are needed before writting 2149 2042 !- 2150 IF (l_dbg) WRITE(*,*) "histwrite: 6.1", pfileid2043 IF (l_dbg) WRITE(*,*) "histwrite: 6.1",idf 2151 2044 !- 2152 2045 IF ( (TRIM(tmp_opp) /= "inst") & 2153 & .AND.(TRIM(tmp_opp) /= "once") ) THEN 2154 rtime = (rtime+last_wrt(pfileid,varid)*deltat(pfileid))/2.0 2046 & .AND.(TRIM(tmp_opp) /= "once") ) THEN 2047 t_bnd(1:2) = (/ W_F(idf)%W_V(iv)%last_wrt*W_F(idf)%deltat,rtime /) 2048 rtime = (t_bnd(1)+t_bnd(2))/2.0 2155 2049 ENDIF 2156 2050 !- … … 2158 2052 !- 2159 2053 IF ( (TRIM(tmp_opp) /= "l_max") & 2160 & .AND.(TRIM(tmp_opp) /= "l_min") & 2161 & .AND.(TRIM(tmp_opp) /= "once") ) THEN 2162 !- 2163 IF (l_dbg) WRITE(*,*) "histwrite: 6.2",pfileid 2164 !- 2165 itax = var_axid(pfileid,varid) 2166 itime = nb_wrt(pfileid,varid)+1 2167 !- 2168 IF (tax_last(pfileid,itax) < itime) THEN 2169 iret = NF90_PUT_VAR (ncid,tdimid(pfileid,itax),(/ rtime /), & 2170 & start=(/ itime /),count=(/ 1 /)) 2171 tax_last(pfileid,itax) = itime 2054 & .AND.(TRIM(tmp_opp) /= "l_min") & 2055 & .AND.(TRIM(tmp_opp) /= "once") ) THEN 2056 !- 2057 IF (l_dbg) WRITE(*,*) "histwrite: 6.2",idf 2058 !- 2059 itax = W_F(idf)%W_V(iv)%t_axid 2060 itime = W_F(idf)%W_V(iv)%nb_wrt+1 2061 !- 2062 IF (W_F(idf)%W_V(itax)%tax_last < itime) THEN 2063 iret = NF90_PUT_VAR (nfid,W_F(idf)%W_V(itax)%tdimid, & 2064 & (/ rtime /),start=(/ itime /),count=(/ 1 /)) 2065 IF (W_F(idf)%W_V(itax)%tbndid > 0) THEN 2066 iret = NF90_PUT_VAR (nfid,W_F(idf)%W_V(itax)%tbndid, & 2067 & t_bnd,start=(/ 1,itime /),count=(/ 2,1 /)) 2068 ENDIF 2069 W_F(idf)%W_V(itax)%tax_last = itime 2172 2070 ENDIF 2173 2071 ELSE … … 2179 2077 !- 2180 2078 IF (l_dbg) THEN 2181 WRITE(*,*) "histwrite: 6.3", pfileid,ncid,ncvarid,varid,itime2182 ENDIF 2183 !- 2184 IF ( scsize(pfileid,varid,3) == 1) THEN2185 IF ( regular(pfileid)) THEN2079 WRITE(*,*) "histwrite: 6.3",idf,nfid,nvid,iv,itime 2080 ENDIF 2081 !- 2082 IF (W_F(idf)%W_V(iv)%scsize(3) == 1) THEN 2083 IF (W_F(idf)%regular) THEN 2186 2084 corner(1:4) = (/ 1,1,itime,0 /) 2187 edges(1:4) = (/ zsize(pfileid,varid,1), &2188 & zsize(pfileid,varid,2),1,0 /)2085 edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1), & 2086 & W_F(idf)%W_V(iv)%zsize(2),1,0 /) 2189 2087 ELSE 2190 2088 corner(1:4) = (/ 1,itime,0,0 /) 2191 edges(1:4) = (/ zsize(pfileid,varid,1),1,0,0 /)2089 edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1),1,0,0 /) 2192 2090 ENDIF 2193 2091 ELSE 2194 IF ( regular(pfileid)) THEN2092 IF (W_F(idf)%regular) THEN 2195 2093 corner(1:4) = (/ 1,1,1,itime /) 2196 edges(1:4) = (/ zsize(pfileid,varid,1), &2197 & zsize(pfileid,varid,2), &2198 & zsize(pfileid,varid,3),1 /)2094 edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1), & 2095 & W_F(idf)%W_V(iv)%zsize(2), & 2096 & W_F(idf)%W_V(iv)%zsize(3),1 /) 2199 2097 ELSE 2200 2098 corner(1:4) = (/ 1,1,itime,0 /) 2201 edges(1:4) = (/ zsize(pfileid,varid,1), &2202 & zsize(pfileid,varid,3),1,0 /)2099 edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1), & 2100 & W_F(idf)%W_V(iv)%zsize(3),1,0 /) 2203 2101 ENDIF 2204 2102 ENDIF 2205 !-2206 ipt = point(pfileid,varid)2207 2103 !- 2208 2104 IF ( (TRIM(tmp_opp) /= "inst") & 2209 2105 & .AND.(TRIM(tmp_opp) /= "once") ) THEN 2210 iret = NF90_PUT_VAR (n cid,ncvarid,buffer(ipt:), &2211 & start=corner(1:4),count=edges(1:4))2106 iret = NF90_PUT_VAR (nfid,nvid,W_F(idf)%W_V(iv)%t_bf, & 2107 & start=corner(1:4),count=edges(1:4)) 2212 2108 ELSE 2213 iret = NF90_PUT_VAR (n cid,ncvarid,buff_tmp2, &2214 & start=corner(1:4),count=edges(1:4))2215 ENDIF 2216 !- 2217 last_wrt(pfileid,varid)= pitau2218 nb_wrt(pfileid,varid) = nb_wrt(pfileid,varid)+12219 nb_opp(pfileid,varid)= 02109 iret = NF90_PUT_VAR (nfid,nvid,tbf_2, & 2110 & start=corner(1:4),count=edges(1:4)) 2111 ENDIF 2112 !- 2113 W_F(idf)%W_V(iv)%last_wrt = pitau 2114 W_F(idf)%W_V(iv)%nb_wrt = W_F(idf)%W_V(iv)%nb_wrt+1 2115 W_F(idf)%W_V(iv)%nb_opp = 0 2220 2116 !--- 2221 2117 ! After the write the file can be synchronized so that no data is … … 2224 2120 ! needed here to switch to this mode. 2225 2121 !--- 2226 ! iret = NF90_SYNC (n cid)2122 ! iret = NF90_SYNC (nfid) 2227 2123 !- 2228 2124 ENDIF … … 2230 2126 END SUBROUTINE histwrite_real 2231 2127 !=== 2232 SUBROUTINE histvar_seq ( pfid,pvarname,pvid)2233 !--------------------------------------------------------------------- 2234 !- This subroutine optimize dthe search for the variable in the table.2128 SUBROUTINE histvar_seq (idf,pvarname,idv) 2129 !--------------------------------------------------------------------- 2130 !- This subroutine optimize the search for the variable in the table. 2235 2131 !- In a first phase it will learn the succession of the variables 2236 2132 !- called and then it will use the table to guess what comes next. … … 2240 2136 !- ARGUMENTS : 2241 2137 !- 2242 !- pfid: id of the file on which we work2138 !- idf : id of the file on which we work 2243 2139 !- pvarname : The name of the variable we are looking for 2244 !- pvid: The var id we found2140 !- idv : The var id we found 2245 2141 !--------------------------------------------------------------------- 2246 2142 IMPLICIT NONE 2247 2143 !- 2248 INTEGER,INTENT(in) :: pfid2144 INTEGER,INTENT(in) :: idf 2249 2145 CHARACTER(LEN=*),INTENT(IN) :: pvarname 2250 INTEGER,INTENT(out) :: pvid2146 INTEGER,INTENT(out) :: idv 2251 2147 !- 2252 2148 LOGICAL,SAVE :: learning(nb_files_max)=.TRUE. … … 2263 2159 !- 2264 2160 IF (l_dbg) THEN 2265 WRITE(*,*) 'histvar_seq, start of the subroutine :',learning( pfid)2266 ENDIF 2267 !- 2268 IF (learning( pfid)) THEN2161 WRITE(*,*) 'histvar_seq, start of the subroutine :',learning(idf) 2162 ENDIF 2163 !- 2164 IF (learning(idf)) THEN 2269 2165 !- 2270 2166 !-- 1.0 We compute the length over which we are going 2271 2167 !-- to check the overlap 2272 2168 !- 2273 IF (overlap( pfid) <= 0) THEN2274 IF ( nb_var(pfid)> 6) THEN2275 overlap( pfid) = nb_var(pfid)/3*22169 IF (overlap(idf) <= 0) THEN 2170 IF (W_F(idf)%n_var > 6) THEN 2171 overlap(idf) = W_F(idf)%n_var/3*2 2276 2172 ELSE 2277 overlap( pfid) = nb_var(pfid)2173 overlap(idf) = W_F(idf)%n_var 2278 2174 ENDIF 2279 2175 ENDIF … … 2281 2177 !-- 1.1 Find the position of this string 2282 2178 !- 2283 CALL find_str ( name(pfid,1:nb_var(pfid)),pvarname,pos)2179 CALL find_str (W_F(idf)%W_V(1:W_F(idf)%n_var)%v_name,pvarname,pos) 2284 2180 IF (pos > 0) THEN 2285 pvid= pos2181 idv = pos 2286 2182 ELSE 2287 2183 CALL ipslerr (3,"histvar_seq", & … … 2294 2190 !-- in the sequence of calls 2295 2191 !- 2296 IF (varseq_err( pfid) >= 0) THEN2297 sp = varseq_len( pfid)+12192 IF (varseq_err(idf) >= 0) THEN 2193 sp = varseq_len(idf)+1 2298 2194 IF (sp <= nb_var_max*3) THEN 2299 varseq( pfid,sp) = pvid2300 varseq_len( pfid) = sp2195 varseq(idf,sp) = idv 2196 varseq_len(idf) = sp 2301 2197 ELSE 2302 2198 CALL ipslerr (2,"histvar_seq",& … … 2308 2204 & ' contact the IOIPSL team. ') 2309 2205 WRITE(*,*) 'The sequence we have found up to now :' 2310 WRITE(*,*) varseq( pfid,1:sp-1)2311 varseq_err( pfid) = -12206 WRITE(*,*) varseq(idf,1:sp-1) 2207 varseq_err(idf) = -1 2312 2208 ENDIF 2313 2209 !- 2314 2210 !---- 1.3 Check if we have found the right overlap 2315 2211 !- 2316 IF (varseq_len( pfid) .GE. overlap(pfid)*2) THEN2212 IF (varseq_len(idf) >= overlap(idf)*2) THEN 2317 2213 !- 2318 2214 !------ We skip a few variables if needed as they could come 2319 2215 !------ from the initialisation of the model. 2320 2216 !- 2321 DO ib = 0,sp-overlap( pfid)*22322 IF ( learning( pfid) .AND.&2323 & SUM(ABS(varseq( pfid,ib+1:ib+overlap(pfid)) -&2324 & varseq( pfid,sp-overlap(pfid)+1:sp))) == 0 ) THEN2325 learning( pfid) = .FALSE.2326 varseq_len( pfid) = sp-overlap(pfid)-ib2327 varseq_pos( pfid) = overlap(pfid)+ib2328 varseq( pfid,1:varseq_len(pfid)) = &2329 & varseq( pfid,ib+1:ib+varseq_len(pfid))2217 DO ib = 0,sp-overlap(idf)*2 2218 IF ( learning(idf) .AND.& 2219 & SUM(ABS(varseq(idf,ib+1:ib+overlap(idf)) -& 2220 & varseq(idf,sp-overlap(idf)+1:sp))) == 0 ) THEN 2221 learning(idf) = .FALSE. 2222 varseq_len(idf) = sp-overlap(idf)-ib 2223 varseq_pos(idf) = overlap(idf)+ib 2224 varseq(idf,1:varseq_len(idf)) = & 2225 & varseq(idf,ib+1:ib+varseq_len(idf)) 2330 2226 ENDIF 2331 2227 ENDDO … … 2337 2233 !-- and we can get a guess at the var ID 2338 2234 !- 2339 nn = varseq_pos( pfid)+12340 IF (nn > varseq_len( pfid)) nn = 12341 !- 2342 pvid = varseq(pfid,nn)2343 !- 2344 IF (TRIM( name(pfid,pvid)) /= TRIM(pvarname)) THEN2345 CALL find_str ( name(pfid,1:nb_var(pfid)),pvarname,pos)2235 nn = varseq_pos(idf)+1 2236 IF (nn > varseq_len(idf)) nn = 1 2237 !- 2238 idv = varseq(idf,nn) 2239 !- 2240 IF (TRIM(W_F(idf)%W_V(idv)%v_name) /= TRIM(pvarname)) THEN 2241 CALL find_str (W_F(idf)%W_V(1:W_F(idf)%n_var)%v_name,pvarname,pos) 2346 2242 IF (pos > 0) THEN 2347 pvid= pos2243 idv = pos 2348 2244 ELSE 2349 2245 CALL ipslerr (3,"histvar_seq", & … … 2352 2248 & TRIM(pvarname)) 2353 2249 ENDIF 2354 varseq_err( pfid) = varseq_err(pfid)+12250 varseq_err(idf) = varseq_err(idf)+1 2355 2251 ELSE 2356 2252 !- … … 2359 2255 !---- not defeat the process. 2360 2256 !- 2361 varseq_pos( pfid) = nn2362 ENDIF 2363 !- 2364 IF (varseq_err( pfid) .GE.10) THEN2365 WRITE(str70,'("for file ",I3)') pfid2257 varseq_pos(idf) = nn 2258 ENDIF 2259 !- 2260 IF (varseq_err(idf) >= 10) THEN 2261 WRITE(str70,'("for file ",I3)') idf 2366 2262 CALL ipslerr (2,"histvar_seq", & 2367 2263 & 'There were 10 errors in the learned sequence of variables',& 2368 2264 & str70,'This looks like a bug, please report it.') 2369 varseq_err( pfid) = 02265 varseq_err(idf) = 0 2370 2266 ENDIF 2371 2267 ENDIF … … 2373 2269 IF (l_dbg) THEN 2374 2270 WRITE(*,*) & 2375 & 'histvar_seq, end of the subroutine :',TRIM(pvarname), pvid2271 & 'histvar_seq, end of the subroutine :',TRIM(pvarname),idv 2376 2272 ENDIF 2377 2273 !------------------------- 2378 2274 END SUBROUTINE histvar_seq 2379 2275 !=== 2380 SUBROUTINE histsync ( file)2276 SUBROUTINE histsync (idf) 2381 2277 !--------------------------------------------------------------------- 2382 2278 !- This subroutine will synchronise all … … 2388 2284 IMPLICIT NONE 2389 2285 !- 2390 ! file : optional argument for fileid 2391 INTEGER,INTENT(in),OPTIONAL :: file 2392 !- 2393 INTEGER :: ifile,ncid,iret 2394 !- 2395 LOGICAL :: file_exists 2286 ! idf : optional argument for fileid 2287 INTEGER,INTENT(in),OPTIONAL :: idf 2288 !- 2289 INTEGER :: ifile,iret,i_s,i_e 2290 !- 2396 2291 LOGICAL :: l_dbg 2397 2292 !--------------------------------------------------------------------- 2398 2293 CALL ipsldbg (old_status=l_dbg) 2399 2294 !- 2400 IF (l_dbg) WRITE(*,*) 'Entering loop on files : ',nb_files 2401 !- 2402 ! 1.The loop on files to synchronise 2403 !- 2404 DO ifile = 1,nb_files 2405 !- 2406 IF (PRESENT(file)) THEN 2407 file_exists = (ifile == file) 2295 IF (l_dbg) THEN 2296 WRITE(*,*) "->histsync" 2297 ENDIF 2298 !- 2299 IF (PRESENT(idf)) THEN 2300 IF ( (idf >= 1).AND.(idf <= nb_files_max) ) THEN 2301 IF (W_F(idf)%ncfid > 0) THEN 2302 i_s = idf 2303 i_e = idf 2304 ELSE 2305 i_s = 1 2306 i_e = 0 2307 CALL ipslerr (2,'histsync', & 2308 & 'Unable to synchronise the file :','probably','not opened') 2309 ENDIF 2408 2310 ELSE 2409 file_exists = .TRUE. 2410 ENDIF 2411 !- 2412 IF (file_exists) THEN 2311 CALL ipslerr (3,'histsync','Invalid file identifier',' ',' ') 2312 ENDIF 2313 ELSE 2314 i_s = 1 2315 i_e = nb_files_max 2316 ENDIF 2317 !- 2318 DO ifile=i_s,i_e 2319 IF (W_F(ifile)%ncfid > 0) THEN 2413 2320 IF (l_dbg) THEN 2414 WRITE(*,*) ' Synchronising specified file number :',file2321 WRITE(*,*) ' histsync - synchronising file number ',ifile 2415 2322 ENDIF 2416 ncid = ncdf_ids(ifile) 2417 iret = NF90_SYNC (ncid) 2418 ENDIF 2419 !- 2323 iret = NF90_SYNC(W_F(ifile)%ncfid) 2324 ENDIF 2420 2325 ENDDO 2326 !- 2327 IF (l_dbg) THEN 2328 WRITE(*,*) "<-histsync" 2329 ENDIF 2421 2330 !---------------------- 2422 2331 END SUBROUTINE histsync 2423 2332 !=== 2424 SUBROUTINE histclo ( fid)2333 SUBROUTINE histclo (idf) 2425 2334 !--------------------------------------------------------------------- 2426 2335 !- This subroutine will close all (or one if defined) opened files … … 2431 2340 IMPLICIT NONE 2432 2341 !- 2433 ! fid : optional argument for fileid 2434 INTEGER,INTENT(in),OPTIONAL :: fid 2435 !- 2436 INTEGER :: ifile,ncid,iret,iv 2437 INTEGER :: start_loop,end_loop 2438 CHARACTER(LEN=70) :: str70 2342 ! idf : optional argument for fileid 2343 INTEGER,INTENT(in),OPTIONAL :: idf 2344 !- 2345 INTEGER :: ifile,nfid,nvid,iret,iv,i_s,i_e 2439 2346 LOGICAL :: l_dbg 2440 2347 !--------------------------------------------------------------------- 2441 2348 CALL ipsldbg (old_status=l_dbg) 2442 2349 !- 2443 IF (l_dbg) WRITE(*,*) 'Entering loop on files :',nb_files 2444 !- 2445 IF (PRESENT(fid)) THEN 2446 start_loop = fid 2447 end_loop = fid 2350 IF (l_dbg) THEN 2351 WRITE(*,*) "->histclo" 2352 ENDIF 2353 !- 2354 IF (PRESENT(idf)) THEN 2355 IF ( (idf >= 1).AND.(idf <= nb_files_max) ) THEN 2356 IF (W_F(idf)%ncfid > 0) THEN 2357 i_s = idf 2358 i_e = idf 2359 ELSE 2360 i_s = 1 2361 i_e = 0 2362 CALL ipslerr (2,'histclo', & 2363 & 'Unable to close the file :','probably','not opened') 2364 ENDIF 2365 ELSE 2366 CALL ipslerr (3,'histclo','Invalid file identifier',' ',' ') 2367 ENDIF 2448 2368 ELSE 2449 start_loop = 1 2450 end_loop = nb_files 2451 ENDIF 2452 !- 2453 DO ifile=start_loop,end_loop 2454 IF (l_dbg) WRITE(*,*) 'Closing specified file number :',ifile 2455 ncid = ncdf_ids(ifile) 2456 iret = NF90_REDEF (ncid) 2457 !--- 2458 !-- 1. Loop on the number of variables to add some final information 2459 !--- 2460 IF (l_dbg) WRITE(*,*) 'Entering loop on vars : ',nb_var(ifile) 2461 DO iv=1,nb_var(ifile) 2462 IF (hist_wrt_rng(ifile,iv)) THEN 2463 IF (l_dbg) THEN 2464 WRITE(*,*) 'min value for file :',ifile,' var n. :',iv, & 2465 & ' is : ',hist_minmax(ifile,iv,1) 2466 WRITE(*,*) 'max value for file :',ifile,' var n. :',iv, & 2467 & ' is : ',hist_minmax(ifile,iv,2) 2369 i_s = 1 2370 i_e = nb_files_max 2371 ENDIF 2372 !- 2373 DO ifile=i_s,i_e 2374 IF (W_F(ifile)%ncfid > 0) THEN 2375 IF (l_dbg) THEN 2376 WRITE(*,*) ' histclo - closing specified file number :',ifile 2377 ENDIF 2378 nfid = W_F(ifile)%ncfid 2379 iret = NF90_REDEF(nfid) 2380 !----- 2381 !---- 1. Loop on the number of variables to add some final information 2382 !----- 2383 IF (l_dbg) THEN 2384 WRITE(*,*) ' Entering loop on vars : ',W_F(ifile)%n_var 2385 ENDIF 2386 DO iv=1,W_F(ifile)%n_var 2387 !------ Extrema 2388 IF (W_F(ifile)%W_V(iv)%hist_wrt_rng) THEN 2389 IF (l_dbg) THEN 2390 WRITE(*,*) 'min value for file :',ifile,' var n. :',iv, & 2391 & ' is : ',W_F(ifile)%W_V(iv)%hist_minmax(1) 2392 WRITE(*,*) 'max value for file :',ifile,' var n. :',iv, & 2393 & ' is : ',W_F(ifile)%W_V(iv)%hist_minmax(2) 2394 ENDIF 2395 IF (W_F(ifile)%W_V(iv)%hist_calc_rng) THEN 2396 !---------- Put the min and max values on the file 2397 nvid = W_F(ifile)%W_V(iv)%ncvid 2398 IF (W_F(ifile)%W_V(iv)%v_typ == hist_r8) THEN 2399 iret = NF90_PUT_ATT(nfid,nvid,'valid_min', & 2400 & REAL(W_F(ifile)%W_V(iv)%hist_minmax(1),KIND=8)) 2401 iret = NF90_PUT_ATT(nfid,nvid,'valid_max', & 2402 & REAL(W_F(ifile)%W_V(iv)%hist_minmax(2),KIND=8)) 2403 ELSE 2404 iret = NF90_PUT_ATT(nfid,nvid,'valid_min', & 2405 & REAL(W_F(ifile)%W_V(iv)%hist_minmax(1),KIND=4)) 2406 iret = NF90_PUT_ATT(nfid,nvid,'valid_max', & 2407 & REAL(W_F(ifile)%W_V(iv)%hist_minmax(2),KIND=4)) 2408 ENDIF 2409 ENDIF 2468 2410 ENDIF 2469 IF (hist_calc_rng(ifile,iv)) THEN 2470 !-------- Put the min and max values on the file 2471 iret = NF90_PUT_ATT (ncid,ncvar_ids(ifile,iv),'valid_min', & 2472 & REAL(hist_minmax(ifile,iv,1),KIND=4)) 2473 iret = NF90_PUT_ATT (ncid,ncvar_ids(ifile,iv),'valid_max', & 2474 & REAL(hist_minmax(ifile,iv,2),KIND=4)) 2411 !------ Time-Buffers 2412 IF (ASSOCIATED(W_F(ifile)%W_V(iv)%t_bf)) THEN 2413 DEALLOCATE(W_F(ifile)%W_V(iv)%t_bf) 2475 2414 ENDIF 2476 ENDIF 2477 ENDDO 2478 !--- 2479 !-- 2. Close the file 2480 !--- 2481 IF (l_dbg) WRITE(*,*) 'close file :',ncid 2482 iret = NF90_CLOSE (ncid) 2483 IF (iret /= NF90_NOERR) THEN 2484 WRITE(str70,'("This file has been already closed :",I3)') ifile 2485 CALL ipslerr (2,'histclo',str70,'','') 2415 !------ Reinitialize the sizes 2416 W_F(ifile)%W_V(iv)%datasz_in(:) = -1 2417 W_F(ifile)%W_V(iv)%datasz_max = -1 2418 ENDDO 2419 !----- 2420 !---- 2. Close the file 2421 !----- 2422 IF (l_dbg) WRITE(*,*) ' close file :',nfid 2423 iret = NF90_CLOSE(nfid) 2424 W_F(ifile)%ncfid = -1 2425 W_F(ifile)%dom_id_svg = -1 2486 2426 ENDIF 2487 2427 ENDDO 2428 !- 2429 IF (l_dbg) THEN 2430 WRITE(*,*) "<-histclo" 2431 ENDIF 2488 2432 !--------------------- 2489 2433 END SUBROUTINE histclo
Note: See TracChangeset
for help on using the changeset viewer.