MODULE histcom !- !$Id$ !- ! This software is governed by the CeCILL license ! See IOIPSL/IOIPSL_License_CeCILL.txt !- USE netcdf USE nc4interface ! needed to allow compilation with netcdf3 libraries !- USE stringop, ONLY : nocomma,cmpblank,findpos,find_str,strlowercase USE mathelp, ONLY : mathop,moycum,buildop USE fliocom, ONLY : flio_dom_file,flio_dom_att USE calendar USE errioipsl, ONLY : ipslerr,ipsldbg !- IMPLICIT NONE !- PRIVATE PUBLIC :: histbeg,histdef,histhori,histvert,histend, & & histwrite,histclo,histsync,ioconf_modname !--------------------------------------------------------------------- !- Some confusing vocabulary in this code ! !- ========================================= !- !- A REGULAR grid is a grid which is i,j indexes !- and thus it is stored in a 2D matrix. !- This is opposed to a IRREGULAR grid which is only in a vector !- and where we do not know which neighbors we have. !- As a consequence we need the bounds for each grid-cell. !- !- A RECTILINEAR grid is a special case of a regular grid !- in which all longitudes for i constant are equal !- and all latitudes for j constant. !- In other words we do not need the full 2D matrix !- to describe the grid, just two vectors. !--------------------------------------------------------------------- !- INTERFACE histbeg MODULE PROCEDURE histb_reg1d,histb_reg2d,histb_irreg END INTERFACE !- INTERFACE histhori MODULE PROCEDURE histh_reg1d,histh_reg2d,histh_irreg END INTERFACE !- INTERFACE histwrite !--------------------------------------------------------------------- !- The "histwrite" routines will give the data to the I/O system. !- It will trigger the operations to be performed, !- and the writting to the file if needed !- !- We test for the work to be done at this time here so that at a !- later stage we can call different operation and write subroutine !- for the REAL and INTEGER interfaces !- !- INPUT !- idf : The ID of the file on which this variable is to be, !- written. The variable should have been defined in !- this file before. !- pvarname : The short name of the variable !- pitau : Current timestep !- pdata : The variable, I mean the real data ! !- nbindex : The number of indexes provided. If it is equal to !- the size of the full field as provided in histdef !- then nothing is done. !- nindex : The indices used to expand the variable (pdata) !- onto the full field. !--------------------------------------------------------------------- !- histwrite - we have to prepare different type of fields : !- real and integer, 1,2 or 3D MODULE PROCEDURE histwrite_r1d,histwrite_r2d,histwrite_r3d END INTERFACE !- ! Fixed parameter !- INTEGER,PARAMETER :: nb_files_max=20,nb_var_max=400, & & nb_hax_max=5,nb_zax_max=10,nbopp_max=10 REAL,PARAMETER :: missing_val=nf90_fill_real INTEGER,PARAMETER,PUBLIC :: & & hist_r4=nf90_real4, hist_r8=nf90_real8 !- ! Variable derived type !- TYPE T_D_V INTEGER :: ncvid INTEGER :: nbopp CHARACTER(LEN=20) :: v_name,unit_name CHARACTER(LEN=256) :: title,std_name CHARACTER(LEN=80) :: fullop CHARACTER(LEN=7) :: topp CHARACTER(LEN=7),DIMENSION(nbopp_max) :: sopp REAL,DIMENSION(nbopp_max) :: scal !-External type (for R4/R8) INTEGER :: v_typ !-Sizes of the associated grid and zommed area INTEGER,DIMENSION(3) :: scsize,zorig,zsize !-Sizes for the data as it goes through the various math operations INTEGER,DIMENSION(3) :: datasz_in = -1 INTEGER :: datasz_max = -1 !- INTEGER :: h_axid,z_axid,t_axid !- REAL,DIMENSION(2) :: hist_minmax LOGICAL :: hist_calc_rng=.FALSE.,hist_wrt_rng=.FALSE. !-Book keeping of the axes INTEGER :: tdimid,tbndid=-1,tax_last LOGICAL :: l_bnd CHARACTER(LEN=40) :: tax_name !- REAL :: freq_opp,freq_wrt INTEGER :: & & last_opp,last_wrt,last_opp_chk,last_wrt_chk,nb_opp,nb_wrt !- For future optimization REAL,POINTER,DIMENSION(:) :: t_bf !# REAL,ALLOCATABLE,DIMENSION(:) :: V_1_D !# REAL,ALLOCATABLE,DIMENSION(:,:) :: V_2_D !# REAL,ALLOCATABLE,DIMENSION(:,:,:) :: V_3_D END TYPE T_D_V !- ! File derived type !- TYPE :: T_D_F !-NETCDF IDs for file INTEGER :: ncfid=-1 !-Time variables INTEGER :: itau0=0 REAL :: date0,deltat !-Counter of elements (variables, time-horizontal-vertical axis INTEGER :: n_var=0,n_tax=0,n_hax=0,n_zax=0 !-NETCDF dimension IDs for time-[time_bounds]-longitude-latitude INTEGER :: tid,bid,xid,yid !-General definitions in the NETCDF file INTEGER,DIMENSION(2) :: full_size=0,slab_ori,slab_siz !-The horizontal axes CHARACTER(LEN=25),DIMENSION(nb_hax_max,2) :: hax_name !-The vertical axes INTEGER,DIMENSION(nb_zax_max) :: zax_size,zax_ids CHARACTER(LEN=20),DIMENSION(nb_zax_max) :: zax_name !- LOGICAL :: regular=.TRUE. !-DOMAIN ID INTEGER :: dom_id_svg=-1 !- TYPE(T_D_V),DIMENSION(nb_var_max) :: W_V END TYPE T_D_F !- TYPE(T_D_F),DIMENSION(nb_files_max),SAVE :: W_F !- ! A list of functions which require special action ! (Needs to be updated when functions are added ! but they are well located here) !- CHARACTER(LEN=30),SAVE :: fuchnbout = 'scatter, fill' !- Some configurable variables with locks CHARACTER(LEN=80),SAVE :: model_name='An IPSL model' LOGICAL,SAVE :: lock_modname=.FALSE. !- !=== CONTAINS !=== !- SUBROUTINE histb_reg1d & & (pfilename,pim,plon,pjm,plat, & & par_orix,par_szx,par_oriy,par_szy, & & pitau0,pdate0,pdeltat,phoriid,idf,domain_id,mode,snc4chunks) !--------------------------------------------------------------------- !- histbeg for 1D regular horizontal coordinates (see histb_all) !--------------------------------------------------------------------- IMPLICIT NONE !- CHARACTER(LEN=*) :: pfilename INTEGER,INTENT(IN) :: pim,pjm REAL,DIMENSION(pim),INTENT(IN) :: plon REAL,DIMENSION(pjm),INTENT(IN) :: plat INTEGER,INTENT(IN):: par_orix,par_szx,par_oriy,par_szy INTEGER,INTENT(IN) :: pitau0 REAL,INTENT(IN) :: pdate0,pdeltat INTEGER,INTENT(OUT) :: idf,phoriid INTEGER,INTENT(IN),OPTIONAL :: domain_id CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode TYPE(snc4_ctl), OPTIONAL,INTENT(IN) :: snc4chunks !--------------------------------------------------------------------- CALL histb_all & & (1,pfilename,pim,pjm,pitau0,pdate0,pdeltat,phoriid,idf, & & x_1d=plon,y_1d=plat, & & k_orx=par_orix,k_szx=par_szx,k_ory=par_oriy,k_szy=par_szy, & & domain_id=domain_id,mode=mode,snc4chunks=snc4chunks) !------------------------- END SUBROUTINE histb_reg1d !=== SUBROUTINE histb_reg2d & & (pfilename,pim,plon,pjm,plat, & & par_orix,par_szx,par_oriy,par_szy, & & pitau0,pdate0,pdeltat,phoriid,idf,domain_id,mode,snc4chunks) !--------------------------------------------------------------------- !- histbeg for 2D regular horizontal coordinates (see histb_all) !--------------------------------------------------------------------- IMPLICIT NONE !- CHARACTER(LEN=*) :: pfilename INTEGER,INTENT(IN) :: pim,pjm REAL,DIMENSION(pim,pjm),INTENT(IN) :: plon,plat INTEGER,INTENT(IN):: par_orix,par_szx,par_oriy,par_szy INTEGER,INTENT(IN) :: pitau0 REAL,INTENT(IN) :: pdate0,pdeltat INTEGER,INTENT(OUT) :: idf,phoriid INTEGER,INTENT(IN),OPTIONAL :: domain_id CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode TYPE(snc4_ctl), OPTIONAL,INTENT(IN) :: snc4chunks !--------------------------------------------------------------------- CALL histb_all & & (2,pfilename,pim,pjm,pitau0,pdate0,pdeltat,phoriid,idf, & & x_2d=plon,y_2d=plat, & & k_orx=par_orix,k_szx=par_szx,k_ory=par_oriy,k_szy=par_szy, & & domain_id=domain_id,mode=mode,snc4chunks=snc4chunks) !------------------------- END SUBROUTINE histb_reg2d !=== SUBROUTINE histb_irreg & & (pfilename,pim,plon,plon_bounds,plat,plat_bounds, & & pitau0,pdate0,pdeltat,phoriid,idf,domain_id,mode,snc4chunks) !--------------------------------------------------------------------- !- histbeg for irregular horizontal coordinates (see histb_all) !--------------------------------------------------------------------- IMPLICIT NONE !- CHARACTER(LEN=*) :: pfilename INTEGER,INTENT(IN) :: pim REAL,DIMENSION(pim),INTENT(IN) :: plon,plat REAL,DIMENSION(:,:),INTENT(IN) :: plon_bounds,plat_bounds INTEGER,INTENT(IN) :: pitau0 REAL,INTENT(IN) :: pdate0,pdeltat INTEGER,INTENT(OUT) :: idf,phoriid INTEGER,INTENT(IN),OPTIONAL :: domain_id CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode TYPE(snc4_ctl), OPTIONAL,INTENT(IN) :: snc4chunks !--------------------------------------------------------------------- CALL histb_all & & (3,pfilename,pim,pim,pitau0,pdate0,pdeltat,phoriid,idf, & & x_1d=plon,y_1d=plat,x_bnds=plon_bounds,y_bnds=plat_bounds, & & domain_id=domain_id,mode=mode,snc4chunks=snc4chunks) !------------------------- END SUBROUTINE histb_irreg !=== SUBROUTINE histb_all & & (k_typ,nc_name,pim,pjm,pitau0,pdate0,pdeltat,phoriid,idf, & & x_1d,y_1d,x_2d,y_2d,k_orx,k_szx,k_ory,k_szy, & & x_bnds,y_bnds,domain_id,mode,snc4chunks) !--------------------------------------------------------------------- !- General interface for horizontal grids. !- This subroutine initializes a netcdf file and returns the ID. !- It will set up the geographical space on which the data will be !- stored and offers the possibility of seting a zoom. !- In the case of irregular grids, all the data comes in as vectors !- and for the grid we have the coordinates of the 4 corners. !- It also gets the global parameters into the I/O subsystem. !- !- INPUT !- !- k_typ : Type of the grid (1 rectilinear, 2 regular, 3 irregular) !- nc_name : Name of the netcdf file to be created !- pim : Size of arrays in longitude direction !- pjm : Size of arrays in latitude direction (pjm=pim for type 3) !- !- pitau0 : time step at which the history tape starts !- pdate0 : The Julian date at which the itau was equal to 0 !- pdeltat : Time step, in seconds, of the counter itau !- used in histwrite for instance !- !- OUTPUT !- !- phoriid : Identifier of the horizontal grid !- idf : Identifier of the file !- !- Optional INPUT arguments !- !- For rectilinear or irregular grid !- x_1d : The longitudes !- y_1d : The latitudes !- For regular grid !- x_2d : The longitudes !- y_2d : The latitudes !- One pair (x_1d,y_1d) or (x_2d,y_2d) must be supplied. !- !- For regular grid (reg1d or reg2d), !- the next 4 arguments allow to define a horizontal zoom !- for this file. It is assumed that all variables to come !- have the same index space. This can not be assumed for !- the z axis and thus we define the zoom in histdef. !- k_orx : Origin of the slab of data within the X axis (pim) !- k_szx : Size of the slab of data in X !- k_ory : Origin of the slab of data within the Y axis (pjm) !- k_szy : Size of the slab of data in Y !- !- For irregular grid. !- x_bnds : The boundaries of the grid in longitude !- y_bnds : The boundaries of the grid in latitude !- !- For all grids. !- !- domain_id : Domain identifier !- !- mode : String of (case insensitive) blank-separated words !- defining the mode used to create the file. !- Supported keywords : 32, 64 !- "32/64" defines the offset mode. !- The default offset mode is 64 bits. !- Keywords "NETCDF4" and "CLASSIC" are reserved !- for future use. !- !- snc4chunks : Structure containing chunk partitioning parameters !- for 4-D variables and a logical switch to toggle !- between netcdf3 o/p (false) and netcdf4 chunked !- and compressed o/p (true) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: k_typ CHARACTER(LEN=*),INTENT(IN) :: nc_name INTEGER,INTENT(IN) :: pim,pjm INTEGER,INTENT(IN) :: pitau0 REAL,INTENT(IN) :: pdate0,pdeltat INTEGER,INTENT(OUT) :: idf,phoriid REAL,DIMENSION(:),INTENT(IN),OPTIONAL :: x_1d,y_1d REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_2d,y_2d INTEGER,INTENT(IN),OPTIONAL :: k_orx,k_szx,k_ory,k_szy REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_bnds,y_bnds INTEGER,INTENT(IN),OPTIONAL :: domain_id CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode TYPE(snc4_ctl), OPTIONAL,INTENT(IN) :: snc4chunks !- INTEGER :: nfid,iret,m_c CHARACTER(LEN=120) :: file CHARACTER(LEN=30) :: timenow CHARACTER(LEN=11) :: c_nam LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (k_typ == 1) THEN c_nam = 'histb_reg1d' ELSEIF (k_typ == 2) THEN c_nam = 'histb_reg2d' ELSEIF (k_typ == 3) THEN c_nam = 'histb_irreg' ELSE CALL ipslerr (3,"histbeg", & & 'Illegal value of k_typ argument','in internal interface','?') ENDIF !- IF (l_dbg) WRITE(*,*) c_nam//" 0.0" !- ! Search for a free index !- idf = -1 DO nfid=1,nb_files_max IF (W_F(nfid)%ncfid < 0) THEN idf = nfid; EXIT; ENDIF ENDDO IF (idf < 0) THEN CALL ipslerr (3,"histbeg", & & 'Table of files too small. You should increase nb_files_max', & & 'in histcom.f90 in order to accomodate all these files',' ') ENDIF !- ! 1.0 Transfering into the common for future use !- IF (l_dbg) WRITE(*,*) c_nam//" 1.0" !- W_F(idf)%itau0 = pitau0 W_F(idf)%date0 = pdate0 W_F(idf)%deltat = pdeltat !- ! 2.0 Initializes all variables for this file !- IF (l_dbg) WRITE(*,*) c_nam//" 2.0" !- W_F(idf)%n_var = 0 W_F(idf)%n_tax = 0 W_F(idf)%n_hax = 0 W_F(idf)%n_zax = 0 !- IF ( (k_typ == 1).OR.(k_typ == 2) ) THEN W_F(idf)%slab_ori(1:2) = (/ k_orx,k_ory /) W_F(idf)%slab_siz(1:2) = (/ k_szx,k_szy /) ELSE W_F(idf)%slab_ori(1:2) = (/ 1,1 /) W_F(idf)%slab_siz(1:2) = (/ pim,1 /) ENDIF !- ! 3.0 Opening netcdf file and defining dimensions !- IF (l_dbg) WRITE(*,*) c_nam//" 3.0" !- ! Add DOMAIN number and ".nc" suffix in file name if needed !- file = nc_name CALL flio_dom_file (file,domain_id) !- ! Check the mode !? See fliocom for HDF4 ???????????????????????????????????????????????? !- IF (PRESENT(mode)) THEN SELECT CASE (TRIM(mode)) CASE('32') m_c = NF90_CLOBBER CASE('64') m_c = IOR(NF90_CLOBBER,NF90_64BIT_OFFSET) CASE DEFAULT CALL ipslerr (3,"histbeg", & & 'Invalid argument mode for file :',TRIM(file), & & 'Supported values are 32 or 64') END SELECT ELSE m_c = IOR(NF90_CLOBBER,NF90_64BIT_OFFSET) ENDIF !- IF (PRESENT(snc4chunks)) THEN IF (snc4chunks%luse) CALL get_nf90_symbol("NF90_HDF5", m_c) ENDIF !- ! Create file !- iret = NF90_CREATE(file,m_c,nfid) !- IF (k_typ == 1) THEN iret = NF90_DEF_DIM(nfid,'lon',k_szx,W_F(idf)%xid) iret = NF90_DEF_DIM(nfid,'lat',k_szy,W_F(idf)%yid) ELSEIF (k_typ == 2) THEN iret = NF90_DEF_DIM(nfid,'x',k_szx,W_F(idf)%xid) iret = NF90_DEF_DIM(nfid,'y',k_szy,W_F(idf)%yid) ELSEIF (k_typ == 3) THEN iret = NF90_DEF_DIM(nfid,'x',pim,W_F(idf)%xid) W_F(idf)%yid = W_F(idf)%xid ENDIF !- ! 4.0 Declaring the geographical coordinates and other attributes !- IF (l_dbg) WRITE(*,*) c_nam//" 4.0" !- iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'Conventions','CF-1.1') iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'file_name',TRIM(file)) iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'production',TRIM(model_name)) lock_modname = .TRUE. CALL ioget_timestamp (timenow) iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'TimeStamp',TRIM(timenow)) !- ! 5.0 Saving some important information on this file in the common !- IF (l_dbg) WRITE(*,*) c_nam//" 5.0" !- IF (PRESENT(domain_id)) THEN W_F(idf)%dom_id_svg = domain_id ENDIF W_F(idf)%ncfid = nfid IF ( (k_typ == 1).OR.(k_typ == 2) ) THEN W_F(idf)%full_size(1:2) = (/ pim,pjm /) W_F(idf)%regular=.TRUE. ELSEIF (k_typ == 3) THEN W_F(idf)%full_size(1:2) = (/ pim,1 /) W_F(idf)%regular=.FALSE. ENDIF !- ! 6.0 storing the geographical coordinates !- IF (k_typ == 1) THEN CALL histh_all & & (k_typ,idf,pim,pjm,' ','Default grid',phoriid, & & x_1d=x_1d,y_1d=y_1d) ELSEIF (k_typ == 2) THEN CALL histh_all & & (k_typ,idf,pim,pjm,' ','Default grid',phoriid, & & x_2d=x_2d,y_2d=y_2d) ELSEIF (k_typ == 3) THEN CALL histh_all & & (k_typ,idf,pim,pim,' ','Default grid',phoriid, & & x_1d=x_1d,y_1d=y_1d,x_bnds=x_bnds,y_bnds=y_bnds) ENDIF !----------------------- END SUBROUTINE histb_all !=== SUBROUTINE histh_reg1d & & (idf,pim,plon,pjm,plat,phname,phtitle,phid) !--------------------------------------------------------------------- !- histhori for 1d regular grid (see histh_all) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: idf,pim,pjm REAL,INTENT(IN),DIMENSION(:) :: plon,plat CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle INTEGER,INTENT(OUT) :: phid !--------------------------------------------------------------------- CALL histh_all & & (1,idf,pim,pjm,phname,phtitle,phid,x_1d=plon,y_1d=plat) !------------------------- END SUBROUTINE histh_reg1d !=== SUBROUTINE histh_reg2d & & (idf,pim,plon,pjm,plat,phname,phtitle,phid) !--------------------------------------------------------------------- !- histhori for 2d regular grid (see histh_all) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: idf,pim,pjm REAL,INTENT(IN),DIMENSION(:,:) :: plon,plat CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle INTEGER,INTENT(OUT) :: phid !--------------------------------------------------------------------- CALL histh_all & & (2,idf,pim,pjm,phname,phtitle,phid,x_2d=plon,y_2d=plat) !------------------------- END SUBROUTINE histh_reg2d !=== SUBROUTINE histh_irreg & & (idf,pim,plon,plon_bounds,plat,plat_bounds,phname,phtitle,phid) !--------------------------------------------------------------------- !- histhori for irregular grid (see histh_all) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: idf,pim REAL,DIMENSION(:),INTENT(IN) :: plon,plat REAL,DIMENSION(:,:),INTENT(IN) :: plon_bounds,plat_bounds CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle INTEGER,INTENT(OUT) :: phid !--------------------------------------------------------------------- CALL histh_all & & (3,idf,pim,pim,phname,phtitle,phid, & & x_1d=plon,y_1d=plat,x_bnds=plon_bounds,y_bnds=plat_bounds) !------------------------- END SUBROUTINE histh_irreg !=== SUBROUTINE histh_all & & (k_typ,idf,pim,pjm,phname,phtitle,phid, & & x_1d,y_1d,x_2d,y_2d,x_bnds,y_bnds) !--------------------------------------------------------------------- !- General interface for horizontal grids. !- This subroutine is made to declare a new horizontal grid. !- It has to have the same number of points as !- the original and thus in this routine we will only !- add two variable (longitude and latitude). !- Any variable in the file can thus point to this pair !- through an attribute. This routine is very usefull !- to allow staggered grids. !- !- INPUT !- !- k_typ : Type of the grid (1 rectilinear, 2 regular, 3 irregular) !- idf : The id of the file to which the grid should be added !- pim : Size in the longitude direction !- pjm : Size in the latitude direction (pjm=pim for type 3) !- phname : The name of grid !- phtitle : The title of the grid !- !- OUTPUT !- !- phid : Id of the created grid !- !- Optional INPUT arguments !- !- For rectilinear or irregular grid !- x_1d : The longitudes !- y_1d : The latitudes !- For regular grid !- x_2d : The longitudes !- y_2d : The latitudes !- One pair (x_1d,y_1d) or (x_2d,y_2d) must be supplied. !- !- For irregular grid. !- x_bnds : The boundaries of the grid in longitude !- y_bnds : The boundaries of the grid in latitude !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: k_typ INTEGER,INTENT(IN) :: idf,pim,pjm CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle INTEGER,INTENT(OUT) :: phid REAL,DIMENSION(:),INTENT(IN),OPTIONAL :: x_1d,y_1d REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_2d,y_2d REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_bnds,y_bnds !- CHARACTER(LEN=25) :: lon_name,lat_name CHARACTER(LEN=30) :: lonbound_name,latbound_name INTEGER :: i_s,i_e INTEGER,DIMENSION(2) :: dims,dims_b INTEGER :: nbbounds INTEGER :: nlonidb,nlatidb,twoid LOGICAL :: transp = .FALSE. REAL,ALLOCATABLE,DIMENSION(:,:) :: bounds_trans REAL :: wmn,wmx INTEGER :: nlonid,nlatid INTEGER :: o_x,o_y,s_x,s_y INTEGER :: iret,nfid CHARACTER(LEN=11) :: c_nam LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (k_typ == 1) THEN c_nam = 'histh_reg1d' ELSEIF (k_typ == 2) THEN c_nam = 'histh_reg2d' ELSEIF (k_typ == 3) THEN c_nam = 'histh_irreg' ELSE CALL ipslerr (3,"histhori", & & 'Illegal value of k_typ argument','in internal interface','?') ENDIF !- ! 1.0 Check that all fits in the buffers !- IF ( (pim /= W_F(idf)%full_size(1)) & & .OR.(W_F(idf)%regular.AND.(pjm /= W_F(idf)%full_size(2))) & & .OR.(.NOT.W_F(idf)%regular.AND.(W_F(idf)%full_size(2) /= 1)) ) THEN CALL ipslerr (3,"histhori", & & 'The new horizontal grid does not have the same size', & & 'as the one provided to histbeg. This is not yet ', & & 'possible in the hist package.') ENDIF !- ! 1.1 Create all the variables needed !- IF (l_dbg) WRITE(*,*) c_nam//" 1.0" !- nfid = W_F(idf)%ncfid !- IF (k_typ == 3) THEN IF (SIZE(x_bnds,DIM=1) == pim) THEN nbbounds = SIZE(x_bnds,DIM=2) transp = .TRUE. ELSEIF (SIZE(x_bnds,DIM=2) == pim) THEN nbbounds = SIZE(x_bnds,DIM=1) transp = .FALSE. ELSE CALL ipslerr (3,"histhori", & & 'The boundary variable does not have any axis corresponding', & & 'to the size of the longitude or latitude variable','.') ENDIF ALLOCATE(bounds_trans(nbbounds,pim)) iret = NF90_DEF_DIM(nfid,'nbnd',nbbounds,twoid) dims_b(1:2) = (/ twoid,W_F(idf)%xid /) ENDIF !- dims(1:2) = (/ W_F(idf)%xid,W_F(idf)%yid /) !- IF (k_typ == 1) THEN IF (W_F(idf)%n_hax == 0) THEN lon_name = 'lon' lat_name = 'lat' ELSE lon_name = 'lon_'//TRIM(phname) lat_name = 'lat_'//TRIM(phname) ENDIF ELSEIF (k_typ == 2) THEN IF (W_F(idf)%n_hax == 0) THEN lon_name = 'nav_lon' lat_name = 'nav_lat' ELSE lon_name = 'nav_lon_'//TRIM(phname) lat_name = 'nav_lat_'//TRIM(phname) ENDIF ELSEIF (k_typ == 3) THEN IF (W_F(idf)%n_hax == 0) THEN lon_name = 'nav_lon' lat_name = 'nav_lat' ELSE lon_name = 'nav_lon_'//TRIM(phname) lat_name = 'nav_lat_'//TRIM(phname) ENDIF lonbound_name = TRIM(lon_name)//'_bounds' latbound_name = TRIM(lat_name)//'_bounds' ENDIF !- ! 1.2 Save the informations !- phid = W_F(idf)%n_hax+1 W_F(idf)%n_hax = phid W_F(idf)%hax_name(phid,1:2) = (/ lon_name,lat_name /) !- ! 2.0 Longitude !- IF (l_dbg) WRITE(*,*) c_nam//" 2.0" !- i_s = 1; IF ( (k_typ == 1).OR.(k_typ == 3) ) THEN i_e = 1; wmn = MINVAL(x_1d); wmx = MAXVAL(x_1d); ELSEIF (k_typ == 2) THEN i_e = 2; wmn = MINVAL(x_2d); wmx = MAXVAL(x_2d); ENDIF iret = NF90_DEF_VAR(nfid,lon_name,NF90_REAL4,dims(i_s:i_e),nlonid) IF (k_typ == 1) THEN iret = NF90_PUT_ATT(nfid,nlonid,'axis',"X") ENDIF iret = NF90_PUT_ATT(nfid,nlonid,'standard_name',"longitude") iret = NF90_PUT_ATT(nfid,nlonid,'units',"degrees_east") iret = NF90_PUT_ATT(nfid,nlonid,'valid_min',REAL(wmn,KIND=4)) iret = NF90_PUT_ATT(nfid,nlonid,'valid_max',REAL(wmx,KIND=4)) iret = NF90_PUT_ATT(nfid,nlonid,'long_name',"Longitude") iret = NF90_PUT_ATT(nfid,nlonid,'nav_model',TRIM(phtitle)) !- IF (k_typ == 3) THEN !--- !-- 2.1 Longitude bounds !--- iret = NF90_PUT_ATT(nfid,nlonid,'bounds',TRIM(lonbound_name)) iret = NF90_DEF_VAR(nfid,lonbound_name,NF90_REAL4,dims_b(1:2),nlonidb) iret = NF90_PUT_ATT(nfid,nlonidb,'long_name', & & 'Boundaries for coordinate variable '//TRIM(lon_name)) ENDIF !- ! 3.0 Latitude !- IF (l_dbg) WRITE(*,*) c_nam//" 3.0" !- i_e = 2; IF ( (k_typ == 1).OR.(k_typ == 3) ) THEN i_s = 2; wmn = MINVAL(y_1d); wmx = MAXVAL(y_1d); ELSEIF (k_typ == 2) THEN i_s = 1; wmn = MINVAL(y_2d); wmx = MAXVAL(y_2d); ENDIF iret = NF90_DEF_VAR(nfid,lat_name,NF90_REAL4,dims(i_s:i_e),nlatid) IF (k_typ == 1) THEN iret = NF90_PUT_ATT(nfid,nlatid,'axis',"Y") ENDIF !- iret = NF90_PUT_ATT(nfid,nlatid,'standard_name',"latitude") iret = NF90_PUT_ATT(nfid,nlatid,'units',"degrees_north") iret = NF90_PUT_ATT(nfid,nlatid,'valid_min',REAL(wmn,KIND=4)) iret = NF90_PUT_ATT(nfid,nlatid,'valid_max',REAL(wmx,KIND=4)) iret = NF90_PUT_ATT(nfid,nlatid,'long_name',"Latitude") iret = NF90_PUT_ATT(nfid,nlatid,'nav_model',TRIM(phtitle)) !- IF (k_typ == 3) THEN !--- !-- 3.1 Latitude bounds !--- iret = NF90_PUT_ATT(nfid,nlatid,'bounds',TRIM(latbound_name)) iret = NF90_DEF_VAR(nfid,latbound_name,NF90_REAL4,dims_b(1:2),nlatidb) iret = NF90_PUT_ATT(nfid,nlatidb,'long_name', & & 'Boundaries for coordinate variable '//TRIM(lat_name)) ENDIF !- iret = NF90_ENDDEF(nfid) !- ! 4.0 storing the geographical coordinates !- IF (l_dbg) WRITE(*,*) c_nam//" 4.0" !- IF ( (k_typ == 1).OR.(k_typ == 2) ) THEN o_x = W_F(idf)%slab_ori(1) o_y = W_F(idf)%slab_ori(2) s_x = W_F(idf)%slab_siz(1) s_y = W_F(idf)%slab_siz(2) !--- !-- Transfer the longitude and the latitude !--- IF (k_typ == 1) THEN iret = NF90_PUT_VAR(nfid,nlonid,x_1d(o_x:o_x+s_x-1)) iret = NF90_PUT_VAR(nfid,nlatid,y_1d(o_y:o_y+s_y-1)) ELSEIF (k_typ == 2) THEN iret = NF90_PUT_VAR(nfid,nlonid, & & x_2d(o_x:o_x+s_x-1,o_y:o_y+s_y-1)) iret = NF90_PUT_VAR(nfid,nlatid, & & y_2d(o_x:o_x+s_x-1,o_y:o_y+s_y-1)) ENDIF ELSEIF (k_typ == 3) THEN !--- !-- Transfer the longitude and the longitude bounds !--- iret = NF90_PUT_VAR(nfid,nlonid,x_1d(1:pim)) !--- IF (transp) THEN bounds_trans = TRANSPOSE(x_bnds) ELSE bounds_trans = x_bnds ENDIF iret = NF90_PUT_VAR(nfid,nlonidb,bounds_trans(1:nbbounds,1:pim)) !--- !-- Transfer the latitude and the latitude bounds !--- iret = NF90_PUT_VAR(nfid,nlatid,y_1d(1:pim)) !--- IF (transp) THEN bounds_trans = TRANSPOSE(y_bnds) ELSE bounds_trans = y_bnds ENDIF iret = NF90_PUT_VAR(nfid,nlatidb,bounds_trans(1:nbbounds,1:pim)) !--- DEALLOCATE(bounds_trans) ENDIF !- iret = NF90_REDEF(nfid) !----------------------- END SUBROUTINE histh_all !=== SUBROUTINE histvert (idf,pzaxname,pzaxtitle,pzaxunit, & & pzsize,pzvalues,pzaxid,pdirect) !--------------------------------------------------------------------- !- This subroutine defines a vertical axis and returns it s id. !- It gives the user the possibility to the user to define many !- different vertical axes. For each variable defined with histdef a !- vertical axis can be specified with by it s ID. !- !- INPUT !- !- idf : ID of the file the variable should be archived in !- pzaxname : Name of the vertical axis !- pzaxtitle: title of the vertical axis !- pzaxunit : Units of the vertical axis (no units if blank string) !- pzsize : size of the vertical axis !- pzvalues : Coordinate values of the vetical axis !- !- pdirect : is an optional argument which allows to specify the !- the positive direction of the axis : up or down. !- OUTPUT !- !- pzaxid : Returns the ID of the axis. !- Note that this is not the netCDF ID ! !- !- VERSION !- !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: idf,pzsize CHARACTER(LEN=*),INTENT(IN) :: pzaxname,pzaxunit,pzaxtitle REAL,INTENT(IN) :: pzvalues(pzsize) INTEGER,INTENT(OUT) :: pzaxid CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: pdirect !- INTEGER :: pos,iv,zdimid,zaxid_tmp CHARACTER(LEN=70) :: str71 CHARACTER(LEN=20) :: direction INTEGER :: iret,leng,nfid LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- ! 1.0 Verifications : ! Do we have enough space for an extra axis ? ! Is the name already in use ? !- IF (l_dbg) WRITE(*,*) "histvert : 1.0 Verifications", & & pzaxname,'---',pzaxunit,'---',pzaxtitle !- ! Direction of the vertical axis. Can we get if from the user. !- IF (PRESENT(pdirect)) THEN direction = TRIM(pdirect) CALL strlowercase (direction) ELSE direction = 'unknown' ENDIF !- ! Check the consistency of the attribute !- IF ( PRESENT(pdirect) & & .AND.(direction /= 'up') & & .AND.(direction /= 'down') ) THEN direction = 'unknown' CALL ipslerr (2,"histvert",& & "The specified positive direction for the vertical axis is invalid.",& & "The value must be up or down.","The attribute will not be written.") ENDIF !- IF (W_F(idf)%n_zax+1 > nb_zax_max) THEN CALL ipslerr (3,"histvert", & & 'Table of vertical axes too small. You should increase ',& & 'nb_zax_max in histcom.f90 in order to accomodate all ', & & 'these variables ') ENDIF !- iv = W_F(idf)%n_zax IF (iv > 1) THEN CALL find_str (W_F(idf)%zax_name(1:iv-1),pzaxname,pos) ELSE pos = 0 ENDIF !- IF (pos > 0) THEN WRITE(str71,'("Check variable ",A," in file",I3)') & & TRIM(pzaxname),idf CALL ipslerr (3,"histvert", & & "Vertical axis already exists",TRIM(str71), & & "Can also be a wrong file ID in another declaration") ENDIF !- iv = W_F(idf)%n_zax+1 !- ! 2.0 Add the information to the file !- IF (l_dbg) & & WRITE(*,*) "histvert : 2.0 Add the information to the file" !- nfid = W_F(idf)%ncfid !- leng = MIN(LEN_TRIM(pzaxname),20) iret = NF90_DEF_DIM (nfid,pzaxname(1:leng),pzsize,zaxid_tmp) iret = NF90_DEF_VAR (nfid,pzaxname(1:leng),NF90_REAL4, & & zaxid_tmp,zdimid) iret = NF90_PUT_ATT (nfid,zdimid,'axis',"Z") iret = NF90_PUT_ATT (nfid,zdimid,'standard_name',"model_level_number") leng = MIN(LEN_TRIM(pzaxunit),20) IF (leng > 0) THEN iret = NF90_PUT_ATT (nfid,zdimid,'units',pzaxunit(1:leng)) ENDIF IF (direction /= 'unknown') THEN iret = NF90_PUT_ATT (nfid,zdimid,'positive',TRIM(direction)) ENDIF iret = NF90_PUT_ATT (nfid,zdimid,'valid_min', & & REAL(MINVAL(pzvalues(1:pzsize)),KIND=4)) iret = NF90_PUT_ATT (nfid,zdimid,'valid_max', & & REAL(MAXVAL(pzvalues(1:pzsize)),KIND=4)) leng = MIN(LEN_TRIM(pzaxname),20) iret = NF90_PUT_ATT (nfid,zdimid,'title',pzaxname(1:leng)) leng = MIN(LEN_TRIM(pzaxtitle),80) iret = NF90_PUT_ATT (nfid,zdimid,'long_name',pzaxtitle(1:leng)) !- iret = NF90_ENDDEF (nfid) !- iret = NF90_PUT_VAR (nfid,zdimid,pzvalues(1:pzsize)) !- iret = NF90_REDEF (nfid) !- !- 3.0 add the information to the common !- IF (l_dbg) & & WRITE(*,*) "histvert : 3.0 add the information to the common" !- W_F(idf)%n_zax = iv W_F(idf)%zax_size(iv) = pzsize W_F(idf)%zax_name(iv) = pzaxname W_F(idf)%zax_ids(iv) = zaxid_tmp pzaxid = iv !---------------------- END SUBROUTINE histvert !=== SUBROUTINE histdef & & (idf,pvarname,ptitle,punit, & & pxsize,pysize,phoriid,pzsize,par_oriz,par_szz,pzid, & & xtype,popp,pfreq_opp,pfreq_wrt,var_range,standard_name) !--------------------------------------------------------------------- !- With this subroutine each variable to be archived on the history !- tape should be declared. !- !- It gives the user the choise of operation !- to be performed on the variables, the frequency of this operation !- and finaly the frequency of the archiving. !- !- INPUT !- !- idf : ID of the file the variable should be archived in !- pvarname : Name of the variable, short and easy to remember !- ptitle : Full name of the variable !- punit : Units of the variable (no units if blank string) !- !- The next 3 arguments give the size of that data !- that will be passed to histwrite. The zoom will be !- done there with the horizontal information obtained !- in histbeg and the vertical information to follow. !- !- pxsize : Size in X direction (size of the data that will be !- given to histwrite) !- pysize : Size in Y direction !- phoriid : ID of the horizontal axis !- !- The next two arguments give the vertical zoom to use. !- !- pzsize : Size in Z direction (If 1 then no axis is declared !- for this variable and pzid is not used) !- par_oriz : Off set of the zoom !- par_szz : Size of the zoom !- !- pzid : ID of the vertical axis to use. It has to have !- the size of the zoom. !- xtype : External netCDF type (hist_r4/hist_r8) !- popp : Operation to be performed. The following options !- exist today : !- inst : keeps instantaneous values for writting !- ave : Computes the average from call between writes !- pfreq_opp: Frequency of this operation (in seconds) !- pfreq_wrt: Frequency at which the variable should be !- written (in seconds) !- var_range: Range of the variable. !- If the minimum is greater than the maximum, !- the values will be calculated. !- !- VERSION !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: idf,pxsize,pysize,pzsize,pzid INTEGER,INTENT(IN) :: par_oriz,par_szz,xtype,phoriid CHARACTER(LEN=*),INTENT(IN) :: pvarname,punit,popp,ptitle REAL,INTENT(IN) :: pfreq_opp,pfreq_wrt REAL,DIMENSION(2),OPTIONAL,INTENT(IN) :: var_range CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: standard_name !- INTEGER :: iv CHARACTER(LEN=70) :: str70,str71,str72 CHARACTER(LEN=20) :: tmp_name CHARACTER(LEN=40) :: str40 CHARACTER(LEN=10) :: str10 CHARACTER(LEN=120) :: ex_topps REAL :: un_an,un_jour,test_fopp,test_fwrt INTEGER :: pos,buff_sz LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- ex_topps = 'ave, inst, t_min, t_max, t_sum, once, never, l_max, l_min' !- W_F(idf)%n_var = W_F(idf)%n_var+1 iv = W_F(idf)%n_var !- IF (iv > nb_var_max) THEN CALL ipslerr (3,"histdef", & & 'Table of variables too small. You should increase nb_var_max',& & 'in histcom.f90 in order to accomodate all these variables', & & ' ') ENDIF !- ! 1.0 Transfer informations on the variable to the common ! and verify that it does not already exist !- IF (l_dbg) WRITE(*,*) "histdef : 1.0" !- IF (iv > 1) THEN CALL find_str (W_F(idf)%W_V(1:iv-1)%v_name,pvarname,pos) ELSE pos = 0 ENDIF !- IF (pos > 0) THEN str70 = "Variable already exists" WRITE(str71,'("Check variable ",a," in file",I3)') & & TRIM(pvarname),idf str72 = "Can also be a wrong file ID in another declaration" CALL ipslerr (3,"histdef",str70,str71,str72) ENDIF !- W_F(idf)%W_V(iv)%v_name = pvarname W_F(idf)%W_V(iv)%title = ptitle W_F(idf)%W_V(iv)%unit_name = punit IF (PRESENT(standard_name)) THEN W_F(idf)%W_V(iv)%std_name = standard_name ELSE W_F(idf)%W_V(iv)%std_name = ptitle ENDIF tmp_name = W_F(idf)%W_V(iv)%v_name !- ! 1.1 decode the operations !- W_F(idf)%W_V(iv)%fullop = popp CALL buildop & & (TRIM(popp),ex_topps,W_F(idf)%W_V(iv)%topp,missing_val, & & W_F(idf)%W_V(iv)%sopp,W_F(idf)%W_V(iv)%scal, & & W_F(idf)%W_V(iv)%nbopp) !- ! 1.2 If we have an even number of operations ! then we need to add identity !- IF ( MOD(W_F(idf)%W_V(iv)%nbopp,2) == 0) THEN W_F(idf)%W_V(iv)%nbopp = W_F(idf)%W_V(iv)%nbopp+1 W_F(idf)%W_V(iv)%sopp(W_F(idf)%W_V(iv)%nbopp) = 'ident' W_F(idf)%W_V(iv)%scal(W_F(idf)%W_V(iv)%nbopp) = missing_val ENDIF !- ! 1.3 External type of the variable !- IF (xtype == hist_r8) THEN W_F(idf)%W_V(iv)%v_typ = hist_r8 ELSE W_F(idf)%W_V(iv)%v_typ = hist_r4 ENDIF !- ! 2.0 Put the size of the variable in the common and check !- IF (l_dbg) THEN WRITE(*,*) "histdef : 2.0",idf,iv,W_F(idf)%W_V(iv)%nbopp, & & W_F(idf)%W_V(iv)%sopp(1:W_F(idf)%W_V(iv)%nbopp), & & W_F(idf)%W_V(iv)%scal(1:W_F(idf)%W_V(iv)%nbopp) ENDIF !- W_F(idf)%W_V(iv)%scsize(1:3) = (/ pxsize,pysize,pzsize /) W_F(idf)%W_V(iv)%zorig(1:3) = & & (/ W_F(idf)%slab_ori(1),W_F(idf)%slab_ori(2),par_oriz /) W_F(idf)%W_V(iv)%zsize(1:3) = & & (/ W_F(idf)%slab_siz(1),W_F(idf)%slab_siz(2),par_szz /) !- ! Is the size of the full array the same as that of the coordinates ? !- IF ( (pxsize > W_F(idf)%full_size(1)) & & .OR.(pysize > W_F(idf)%full_size(2)) ) THEN !- str70 = "The size of the variable is different "// & & "from the one of the coordinates" WRITE(str71,'("Size of coordinates :",2I4)') & & W_F(idf)%full_size(1),W_F(idf)%full_size(2) WRITE(str72,'("Size declared for variable ",a," :",2I4)') & & TRIM(tmp_name),pxsize,pysize CALL ipslerr (3,"histdef",str70,str71,str72) ENDIF !- ! Is the size of the zoom smaller than the coordinates ? !- IF ( (W_F(idf)%full_size(1) < W_F(idf)%slab_siz(1)) & & .OR.(W_F(idf)%full_size(2) < W_F(idf)%slab_siz(2)) ) THEN str70 = & & "Size of variable should be greater or equal to those of the zoom" WRITE(str71,'("Size of XY zoom :",2I4)') & & W_F(idf)%slab_siz(1),W_F(idf)%slab_siz(2) WRITE(str72,'("Size declared for variable ",A," :",2I4)') & & TRIM(tmp_name),pxsize,pysize CALL ipslerr (3,"histdef",str70,str71,str72) ENDIF !- ! 2.1 We store the horizontal grid information with minimal ! and a fall back onto the default grid !- IF ( (phoriid > 0).AND.(phoriid <= W_F(idf)%n_hax) ) THEN W_F(idf)%W_V(iv)%h_axid = phoriid ELSE W_F(idf)%W_V(iv)%h_axid = 1 CALL ipslerr (2,"histdef", & & 'We use the default grid for variable as an invalide',& & 'ID was provided for variable : ',TRIM(pvarname)) ENDIF !- ! 2.2 Check the vertical coordinates if needed !- IF (par_szz > 1) THEN !- !-- Does the vertical coordinate exist ? !- IF (pzid > W_F(idf)%n_zax) THEN WRITE(str70, & & '("The vertical coordinate chosen for variable ",A)') & & TRIM(tmp_name) str71 = " Does not exist." CALL ipslerr (3,"histdef",str70,str71," ") ENDIF !- !-- Is the vertical size of the variable equal to that of the axis ? !- IF (par_szz /= W_F(idf)%zax_size(pzid)) THEN str70 = "The size of the zoom does not correspond "// & & "to the size of the chosen vertical axis" WRITE(str71,'("Size of zoom in z :",I4)') par_szz WRITE(str72,'("Size declared for axis ",A," :",I4)') & & TRIM(W_F(idf)%zax_name(pzid)),W_F(idf)%zax_size(pzid) CALL ipslerr (3,"histdef",str70,str71,str72) ENDIF !- !-- Is the zoom smaller that the total size of the variable ? !- IF (pzsize < par_szz) THEN str70 = "The vertical size of variable "// & & "is smaller than that of the zoom." WRITE(str71,'("Declared vertical size of data :",I5)') pzsize WRITE(str72,'("Size of zoom for variable ",a," = ",I5)') & & TRIM(tmp_name),par_szz CALL ipslerr (3,"histdef",str70,str71,str72) ENDIF W_F(idf)%W_V(iv)%z_axid = pzid ELSE W_F(idf)%W_V(iv)%z_axid = -99 ENDIF !- ! 3.0 We get the size of the arrays histwrite will get ! and eventually allocate the time_buffer !- IF (l_dbg) THEN WRITE(*,*) "histdef : 3.0" ENDIF !- buff_sz = W_F(idf)%W_V(iv)%zsize(1) & & *W_F(idf)%W_V(iv)%zsize(2) & & *W_F(idf)%W_V(iv)%zsize(3) !- IF ( (TRIM(W_F(idf)%W_V(iv)%topp) /= "inst") & & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= "once") & & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= "never") )THEN ALLOCATE(W_F(idf)%W_V(iv)%t_bf(buff_sz)) W_F(idf)%W_V(iv)%t_bf(:) = 0. IF (l_dbg) THEN WRITE(*,*) "histdef : 3.0 allocating time_buffer for", & & " idf = ",idf," iv = ",iv," size = ",buff_sz ENDIF ENDIF !- ! 4.0 Transfer the frequency of the operations and check ! for validity. We have to pay attention to negative values ! of the frequency which indicate monthly time-steps. ! The strategy is to bring it back to seconds for the tests !- IF (l_dbg) WRITE(*,*) "histdef : 4.0" !- W_F(idf)%W_V(iv)%freq_opp = pfreq_opp W_F(idf)%W_V(iv)%freq_wrt = pfreq_wrt !- CALL ioget_calendar(un_an,un_jour) IF (pfreq_opp < 0) THEN CALL ioget_calendar(un_an) test_fopp = pfreq_opp*(-1.)*un_an/12.*un_jour ELSE test_fopp = pfreq_opp ENDIF IF (pfreq_wrt < 0) THEN CALL ioget_calendar(un_an) test_fwrt = pfreq_wrt*(-1.)*un_an/12.*un_jour ELSE test_fwrt = pfreq_wrt ENDIF !- ! 4.1 Frequency of operations and output should be larger than deltat ! !- IF (test_fopp < W_F(idf)%deltat) THEN str70 = 'Frequency of operations should be larger than deltat' WRITE(str71,'("It is not the case for variable ",a," :",F10.4)') & & TRIM(tmp_name),pfreq_opp str72 = "PATCH : frequency set to deltat" !- CALL ipslerr (2,"histdef",str70,str71,str72) !- W_F(idf)%W_V(iv)%freq_opp = W_F(idf)%deltat ENDIF !- IF (test_fwrt < W_F(idf)%deltat) THEN str70 = 'Frequency of output should be larger than deltat' WRITE(str71,'("It is not the case for variable ",a," :",F10.4)') & & TRIM(tmp_name),pfreq_wrt str72 = "PATCH : frequency set to deltat" !- CALL ipslerr (2,"histdef",str70,str71,str72) !- W_F(idf)%W_V(iv)%freq_wrt = W_F(idf)%deltat ENDIF !- ! 4.2 First the existence of the operation is tested and then ! its compaticility with the choice of frequencies !- IF (TRIM(W_F(idf)%W_V(iv)%topp) == "inst") THEN IF (test_fopp /= test_fwrt) THEN str70 = 'For instantaneous output the frequency '// & & 'of operations and output' WRITE(str71, & & '("should be the same, this was not case for variable ",a)') & & TRIM(tmp_name) str72 = "PATCH : The smalest frequency of both is used" CALL ipslerr (2,"histdef",str70,str71,str72) IF (test_fopp < test_fwrt) THEN W_F(idf)%W_V(iv)%freq_opp = pfreq_opp W_F(idf)%W_V(iv)%freq_wrt = pfreq_opp ELSE W_F(idf)%W_V(iv)%freq_opp = pfreq_wrt W_F(idf)%W_V(iv)%freq_wrt = pfreq_wrt ENDIF ENDIF ELSE IF (INDEX(ex_topps,TRIM(W_F(idf)%W_V(iv)%topp)) > 0) THEN IF (test_fopp > test_fwrt) THEN str70 = 'For averages the frequency of operations '// & & 'should be smaller or equal' WRITE(str71, & & '("to that of output. It is not the case for variable ",a)') & & TRIM(tmp_name) str72 = 'PATCH : The output frequency is used for both' CALL ipslerr (2,"histdef",str70,str71,str72) W_F(idf)%W_V(iv)%freq_opp = pfreq_wrt ENDIF ELSE WRITE (str70,'("Operation on variable ",A," is unknown")') & & TRIM(tmp_name) WRITE (str71,'("operation requested is :",A)') & & W_F(idf)%W_V(iv)%topp WRITE (str72,'("File ID :",I3)') idf CALL ipslerr (3,"histdef",str70,str71,str72) ENDIF !- ! 5.0 Initialize other variables of the common !- IF (l_dbg) WRITE(*,*) "histdef : 5.0" !- W_F(idf)%W_V(iv)%hist_wrt_rng = (PRESENT(var_range)) IF (W_F(idf)%W_V(iv)%hist_wrt_rng) THEN W_F(idf)%W_V(iv)%hist_calc_rng = (var_range(1) > var_range(2)) IF (W_F(idf)%W_V(iv)%hist_calc_rng) THEN W_F(idf)%W_V(iv)%hist_minmax(1:2) = & & (/ ABS(missing_val),-ABS(missing_val) /) ELSE W_F(idf)%W_V(iv)%hist_minmax(1:2) = var_range(1:2) ENDIF ENDIF !- ! - freq_opp(idf,iv)/2./deltat(idf) W_F(idf)%W_V(iv)%last_opp = W_F(idf)%itau0 ! - freq_wrt(idf,iv)/2./deltat(idf) W_F(idf)%W_V(iv)%last_wrt = W_F(idf)%itau0 ! - freq_opp(idf,iv)/2./deltat(idf) W_F(idf)%W_V(iv)%last_opp_chk = W_F(idf)%itau0 ! - freq_wrt(idf,iv)/2./deltat(idf) W_F(idf)%W_V(iv)%last_wrt_chk = W_F(idf)%itau0 W_F(idf)%W_V(iv)%nb_opp = 0 W_F(idf)%W_V(iv)%nb_wrt = 0 !- ! 6.0 Get the time axis for this variable !- IF (l_dbg) WRITE(*,*) "histdef : 6.0" !- ! No time axis for once, l_max, l_min or never operation !- IF ( (TRIM(W_F(idf)%W_V(iv)%topp) /= 'once') & & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= 'never') & & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= 'l_max') & & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= 'l_min') ) THEN IF (TRIM(W_F(idf)%W_V(iv)%topp) == 'inst') THEN str10 = 't_inst_' ELSE str10 = 't_op_' ENDIF IF (W_F(idf)%W_V(iv)%freq_wrt > 0) THEN WRITE (UNIT=str40,FMT='(A,I8.8)') & & TRIM(str10),INT(W_F(idf)%W_V(iv)%freq_wrt) ELSE WRITE (UNIT=str40,FMT='(A,I2.2,"month")') & & TRIM(str10),ABS(INT(W_F(idf)%W_V(iv)%freq_wrt)) ENDIF CALL find_str (W_F(idf)%W_V(1:W_F(idf)%n_tax)%tax_name,str40,pos) IF (pos < 0) THEN W_F(idf)%n_tax = W_F(idf)%n_tax+1 W_F(idf)%W_V(iv)%l_bnd = & & (TRIM(W_F(idf)%W_V(iv)%topp) /= 'inst') W_F(idf)%W_V(W_F(idf)%n_tax)%tax_name = str40 W_F(idf)%W_V(W_F(idf)%n_tax)%tax_last = 0 W_F(idf)%W_V(iv)%t_axid = W_F(idf)%n_tax ELSE W_F(idf)%W_V(iv)%t_axid = pos ENDIF ELSE IF (l_dbg) THEN WRITE(*,*) "histdef : 7.0 ",TRIM(W_F(idf)%W_V(iv)%topp),'----' ENDIF W_F(idf)%W_V(iv)%t_axid = -99 ENDIF !- ! 7.0 prepare frequence of writing and operation ! for never or once operation !- IF ( (TRIM(W_F(idf)%W_V(iv)%topp) == 'once') & & .OR.(TRIM(W_F(idf)%W_V(iv)%topp) == 'never') ) THEN W_F(idf)%W_V(iv)%freq_opp = 0. W_F(idf)%W_V(iv)%freq_wrt = 0. ENDIF !--------------------- END SUBROUTINE histdef !=== SUBROUTINE histend (idf, snc4chunks) !--------------------------------------------------------------------- !- This subroutine end the decalaration of variables and sets the !- time axes in the netcdf file and puts it into the write mode. !- !- INPUT !- !- idf : ID of the file to be worked on !- !- VERSION !- !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: idf TYPE(snc4_ctl), OPTIONAL,INTENT(IN) :: snc4chunks !- INTEGER :: nfid,nvid,iret,ndim,iv,itx,ziv,itax,dim_cnt INTEGER,DIMENSION(4) :: dims INTEGER :: year,month,day,hours,minutes REAL :: sec REAL :: rtime0 CHARACTER(LEN=30) :: str30 CHARACTER(LEN=35) :: str35 CHARACTER(LEN=120) :: assoc CHARACTER(LEN=70) :: str70 CHARACTER(LEN=3),DIMENSION(12) :: cal = & & (/ 'JAN','FEB','MAR','APR','MAY','JUN', & & 'JUL','AUG','SEP','OCT','NOV','DEC' /) CHARACTER(LEN=7) :: tmp_opp LOGICAL :: l_b LOGICAL :: l_dbg INTEGER, DIMENSION(4) :: ichunksz ! NETCDF4 chunk sizes INTEGER :: ichunkalg, ishuffle,& ideflate, ideflate_level LOGICAL :: lchunk = .FALSE. ! logical switch to activate chunking when appropriate !- ! NetCDF4 chunking and compression parameters ichunkalg = 0 ishuffle = 1 ideflate = 1 ideflate_level = 1 ! !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- nfid = W_F(idf)%ncfid !- ! 1.0 Create the time axes !- IF (l_dbg) WRITE(*,*) "histend : 1.0" !- ! 1.1 Define the time dimensions needed for this file !- iret = NF90_DEF_DIM (nfid,'time_counter', & & NF90_UNLIMITED,W_F(idf)%tid) DO iv=1,W_F(idf)%n_var IF (W_F(idf)%W_V(iv)%l_bnd) THEN iret = NF90_DEF_DIM (nfid,'tbnds',2,W_F(idf)%bid) EXIT ENDIF ENDDO !- ! 1.2 Define all the time axes needed for this file !- DO itx=1,W_F(idf)%n_tax dims(1) = W_F(idf)%tid l_b = (INDEX(W_F(idf)%W_V(itx)%tax_name,"t_op_") == 1) IF (itx > 1) THEN str30 = W_F(idf)%W_V(itx)%tax_name ELSE str30 = "time_counter" ENDIF IF (l_b) THEN str35 = TRIM(str30)//'_bnds' ENDIF iret = NF90_DEF_VAR (nfid,TRIM(str30),NF90_REAL8, & & dims(1),W_F(idf)%W_V(itx)%tdimid) IF (itx <= 1) THEN iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid,'axis',"T") ENDIF iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & & 'standard_name',"time") !--- ! To transform the current itau into a real date and take it ! as the origin of the file requires the time counter to change. ! Thus it is an operation the user has to ask for. ! This function should thus only be re-instated ! if there is a ioconf routine to control it. !--- !-- rtime0 = itau2date(itau0(idf),date0(idf),deltat(idf)) rtime0 = W_F(idf)%date0 !- CALL ju2ymds(rtime0,year,month,day,sec) !--- ! Catch any error induced by a change in calendar ! !--- IF (year < 0) THEN year = 2000+year ENDIF !- hours = INT(sec/(60.*60.)) minutes = INT((sec-hours*60.*60.)/60.) sec = sec-(hours*60.*60.+minutes*60.) !- WRITE (UNIT=str70, & & FMT='(A,I4.4,"-",I2.2,"-",I2.2," ",I2.2,":",I2.2,":",I2.2)') & & 'seconds since ',year,month,day,hours,minutes,INT(sec) iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & & 'units',TRIM(str70)) !- CALL ioget_calendar (str30) iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & & 'calendar',TRIM(str30)) !- iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & & 'title','Time') !- iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & & 'long_name','Time axis') !- WRITE (UNIT=str70, & & FMT='(" ",I4.4,"-",A3,"-",I2.2," ",I2.2,":",I2.2,":",I2.2)') & & year,cal(month),day,hours,minutes,INT(sec) iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & & 'time_origin',TRIM(str70)) !--- IF (l_b) THEN iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & & 'bounds',TRIM(str35)) dims(1:2) = (/ W_F(idf)%bid,W_F(idf)%tid /) iret = NF90_DEF_VAR (nfid,TRIM(str35),NF90_REAL8, & & dims(1:2),W_F(idf)%W_V(itx)%tbndid) ENDIF ENDDO !- ! 2.0 declare the variables !- IF (l_dbg) WRITE(*,*) "histend : 2.0" !- DO iv=1,W_F(idf)%n_var !--- itax = W_F(idf)%W_V(iv)%t_axid !--- IF (W_F(idf)%regular) THEN dims(1:2) = (/ W_F(idf)%xid,W_F(idf)%yid /) dim_cnt = 2 ELSE dims(1) = W_F(idf)%xid dim_cnt = 1 ENDIF !--- tmp_opp = W_F(idf)%W_V(iv)%topp ziv = W_F(idf)%W_V(iv)%z_axid !--- ! 2.1 dimension of field !--- IF ((TRIM(tmp_opp) /= 'never')) THEN IF ( (TRIM(tmp_opp) /= 'once') & & .AND.(TRIM(tmp_opp) /= 'l_max') & & .AND.(TRIM(tmp_opp) /= 'l_min') ) THEN IF (ziv == -99) THEN ndim = dim_cnt+1 dims(dim_cnt+1:dim_cnt+2) = (/ W_F(idf)%tid,0 /) ELSE ndim = dim_cnt+2 dims(dim_cnt+1:dim_cnt+2) = & & (/ W_F(idf)%zax_ids(ziv),W_F(idf)%tid /) ENDIF ELSE IF (ziv == -99) THEN ndim = dim_cnt dims(dim_cnt+1:dim_cnt+2) = (/ 0,0 /) ELSE ndim = dim_cnt+1 dims(dim_cnt+1:dim_cnt+2) = (/ W_F(idf)%zax_ids(ziv),0 /) ENDIF ENDIF !- iret = NF90_DEF_VAR (nfid,TRIM(W_F(idf)%W_V(iv)%v_name), & & W_F(idf)%W_V(iv)%v_typ,dims(1:ABS(ndim)),nvid) !- IF( ndim == 4 ) THEN IF( PRESENT( snc4chunks ) ) THEN IF( snc4chunks%luse ) THEN ichunksz = 1 iret = NF90_INQUIRE_DIMENSION( nfid, W_F(idf)%xid, len = ichunksz(1) ) iret = NF90_INQUIRE_DIMENSION( nfid, W_F(idf)%yid, len = ichunksz(2) ) IF ( ziv .NE. -99 ) & iret = NF90_INQUIRE_DIMENSION( nfid, W_F(idf)%zax_ids(ziv), len = ichunksz(3) ) ichunksz(1) = MIN(ichunksz(1), MAX((ichunksz(1)-1)/snc4chunks%ni + 1,16)) ichunksz(2) = MIN(ichunksz(2), MAX((ichunksz(2)-1)/snc4chunks%nj + 1,16)) ichunksz(3) = MIN(ichunksz(3), MAX((ichunksz(3)-1)/snc4chunks%nk + 1, 1)) ! Always use a chunk size of 1 for the unlimited dimension iret = SET_NF90_DEF_VAR_CHUNKING(nfid, nvid, ichunkalg, ichunksz) iret = SET_NF90_DEF_VAR_DEFLATE(nfid, nvid, ishuffle, ideflate, ideflate_level) ENDIF ENDIF ENDIF W_F(idf)%W_V(iv)%ncvid = nvid !- IF (LEN_TRIM(W_F(idf)%W_V(iv)%unit_name) > 0) THEN iret = NF90_PUT_ATT (nfid,nvid,'units', & & TRIM(W_F(idf)%W_V(iv)%unit_name)) ENDIF iret = NF90_PUT_ATT (nfid,nvid,'standard_name', & & TRIM(W_F(idf)%W_V(iv)%std_name)) !- IF (W_F(idf)%W_V(iv)%v_typ == hist_r8) THEN iret = NF90_PUT_ATT (nfid,nvid,'_FillValue',NF90_FILL_REAL8) ELSE iret = NF90_PUT_ATT (nfid,nvid,'_FillValue',NF90_FILL_REAL4) ENDIF IF (W_F(idf)%W_V(iv)%hist_wrt_rng) THEN IF (W_F(idf)%W_V(iv)%v_typ == hist_r8) THEN iret = NF90_PUT_ATT (nfid,nvid,'valid_min', & & REAL(W_F(idf)%W_V(iv)%hist_minmax(1),KIND=8)) iret = NF90_PUT_ATT (nfid,nvid,'valid_max', & & REAL(W_F(idf)%W_V(iv)%hist_minmax(2),KIND=8)) ELSE iret = NF90_PUT_ATT (nfid,nvid,'valid_min', & & REAL(W_F(idf)%W_V(iv)%hist_minmax(1),KIND=4)) iret = NF90_PUT_ATT (nfid,nvid,'valid_max', & & REAL(W_F(idf)%W_V(iv)%hist_minmax(2),KIND=4)) ENDIF ENDIF iret = NF90_PUT_ATT (nfid,nvid,'long_name', & & TRIM(W_F(idf)%W_V(iv)%title)) iret = NF90_PUT_ATT (nfid,nvid,'online_operation', & & TRIM(W_F(idf)%W_V(iv)%fullop)) !- SELECT CASE(ndim) CASE(-3,2:4) CASE DEFAULT CALL ipslerr (3,"histend", & & 'less than 2 or more than 4 dimensions are not', & & 'allowed at this stage',' ') END SELECT !- assoc=TRIM(W_F(idf)%hax_name(W_F(idf)%W_V(iv)%h_axid,2)) & & //' '//TRIM(W_F(idf)%hax_name(W_F(idf)%W_V(iv)%h_axid,1)) !- ziv = W_F(idf)%W_V(iv)%z_axid IF (ziv > 0) THEN str30 = W_F(idf)%zax_name(ziv) assoc = TRIM(str30)//' '//TRIM(assoc) ENDIF !- IF (itax > 0) THEN IF (itax > 1) THEN str30 = W_F(idf)%W_V(itax)%tax_name ELSE str30 = "time_counter" ENDIF assoc = TRIM(str30)//' '//TRIM(assoc) !- IF (l_dbg) THEN WRITE(*,*) "histend : 2.0.n, freq_opp, freq_wrt", & & W_F(idf)%W_V(iv)%freq_opp,W_F(idf)%W_V(iv)%freq_wrt ENDIF !- iret = NF90_PUT_ATT (nfid,nvid,'interval_operation', & & REAL(W_F(idf)%W_V(iv)%freq_opp,KIND=4)) iret = NF90_PUT_ATT (nfid,nvid,'interval_write', & & REAL(W_F(idf)%W_V(iv)%freq_wrt,KIND=4)) ENDIF iret = NF90_PUT_ATT (nfid,nvid,'coordinates',TRIM(assoc)) ENDIF ENDDO !- ! 2.2 Add DOMAIN attributes if needed !- IF (W_F(idf)%dom_id_svg >= 0) THEN CALL flio_dom_att (nfid,W_F(idf)%dom_id_svg) ENDIF !- ! 3.0 Put the netcdf file into write mode !- IF (l_dbg) WRITE(*,*) "histend : 3.0" !- iret = NF90_ENDDEF (nfid) !- ! 4.0 Give some informations to the user !- IF (l_dbg) WRITE(*,*) "histend : 4.0" !- !!$ WRITE(str70,'("All variables have been initialized on file :",I3)') idf !!$ CALL ipslerr (1,'histend',str70,'',' ') !--------------------- END SUBROUTINE histend !=== SUBROUTINE histwrite_r1d (idf,pvarname,pitau,pdata,nbindex,nindex) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: idf,pitau,nbindex INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex REAL,DIMENSION(:),INTENT(IN) :: pdata CHARACTER(LEN=*),INTENT(IN) :: pvarname !--------------------------------------------------------------------- CALL histw_rnd (idf,pvarname,pitau,nbindex,nindex,pdata_1d=pdata) !--------------------------- END SUBROUTINE histwrite_r1d !=== SUBROUTINE histwrite_r2d (idf,pvarname,pitau,pdata,nbindex,nindex) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: idf,pitau,nbindex INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex REAL,DIMENSION(:,:),INTENT(IN) :: pdata CHARACTER(LEN=*),INTENT(IN) :: pvarname !--------------------------------------------------------------------- CALL histw_rnd (idf,pvarname,pitau,nbindex,nindex,pdata_2d=pdata) !--------------------------- END SUBROUTINE histwrite_r2d !=== SUBROUTINE histwrite_r3d (idf,pvarname,pitau,pdata,nbindex,nindex) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: idf,pitau,nbindex INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex REAL,DIMENSION(:,:,:),INTENT(IN) :: pdata CHARACTER(LEN=*),INTENT(IN) :: pvarname !--------------------------------------------------------------------- CALL histw_rnd (idf,pvarname,pitau,nbindex,nindex,pdata_3d=pdata) !--------------------------- END SUBROUTINE histwrite_r3d !=== SUBROUTINE histw_rnd (idf,pvarname,pitau,nbindex,nindex, & & pdata_1d,pdata_2d,pdata_3d) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: idf,pitau,nbindex INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex CHARACTER(LEN=*),INTENT(IN) :: pvarname REAL,DIMENSION(:),INTENT(IN),OPTIONAL :: pdata_1d REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: pdata_2d REAL,DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: pdata_3d !- LOGICAL :: do_oper,do_write,largebuf,l1d,l2d,l3d INTEGER :: iv,io,nbpt_out INTEGER :: nbpt_in1 INTEGER,DIMENSION(2) :: nbpt_in2 INTEGER,DIMENSION(3) :: nbpt_in3 REAL,ALLOCATABLE,DIMENSION(:),SAVE :: tbf_1 CHARACTER(LEN=7) :: tmp_opp CHARACTER(LEN=13) :: c_nam LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- l1d=PRESENT(pdata_1d); l2d=PRESENT(pdata_2d); l3d=PRESENT(pdata_3d); IF (l1d) THEN c_nam = 'histwrite_r1d' ELSE IF (l2d) THEN c_nam = 'histwrite_r2d' ELSE IF (l3d) THEN c_nam = 'histwrite_r3d' ENDIF !- IF (l_dbg) THEN WRITE(*,*) "histwrite : ",c_nam ENDIF !- ! 1.0 Try to catch errors like specifying the wrong file ID. ! Thanks Marine for showing us what errors users can make ! !- IF ( (idf < 1).OR.(idf > nb_files_max) ) THEN CALL ipslerr (3,"histwrite", & & 'Illegal file ID in the histwrite of variable',pvarname,' ') ENDIF !- ! 1.1 Find the id of the variable to be written and the real time !- CALL histvar_seq (idf,pvarname,iv) !- ! 2.0 do nothing for never operation !- tmp_opp = W_F(idf)%W_V(iv)%topp !- IF (TRIM(tmp_opp) == "never") THEN W_F(idf)%W_V(iv)%last_opp_chk = -99 W_F(idf)%W_V(iv)%last_wrt_chk = -99 ENDIF !- ! 3.0 We check if we need to do an operation !- IF (W_F(idf)%W_V(iv)%last_opp_chk == pitau) THEN CALL ipslerr (3,"histwrite", & & 'This variable has already been analysed at the present', & & 'time step',TRIM(pvarname)) ENDIF !- CALL isittime & & (pitau,W_F(idf)%date0,W_F(idf)%deltat, & & W_F(idf)%W_V(iv)%freq_opp, & & W_F(idf)%W_V(iv)%last_opp, & & W_F(idf)%W_V(iv)%last_opp_chk,do_oper) !- ! 4.0 We check if we need to write the data !- IF (W_F(idf)%W_V(iv)%last_wrt_chk == pitau) THEN CALL ipslerr (3,"histwrite", & & 'This variable as already been written for the present', & & 'time step',' ') ENDIF !- CALL isittime & & (pitau,W_F(idf)%date0,W_F(idf)%deltat, & & W_F(idf)%W_V(iv)%freq_wrt, & & W_F(idf)%W_V(iv)%last_wrt, & & W_F(idf)%W_V(iv)%last_wrt_chk,do_write) !- ! 5.0 histwrite called !- IF (do_oper.OR.do_write) THEN !- !-- 5.1 Get the sizes of the data we will handle !- IF (W_F(idf)%W_V(iv)%datasz_in(1) <= 0) THEN !---- There is the risk here that the user has over-sized the array. !---- But how can we catch this ? !---- In the worst case we will do impossible operations !---- on part of the data ! W_F(idf)%W_V(iv)%datasz_in(1:3) = -1 IF (l1d) THEN W_F(idf)%W_V(iv)%datasz_in(1) = SIZE(pdata_1d) ELSE IF (l2d) THEN W_F(idf)%W_V(iv)%datasz_in(1) = SIZE(pdata_2d,DIM=1) W_F(idf)%W_V(iv)%datasz_in(2) = SIZE(pdata_2d,DIM=2) ELSE IF (l3d) THEN W_F(idf)%W_V(iv)%datasz_in(1) = SIZE(pdata_3d,DIM=1) W_F(idf)%W_V(iv)%datasz_in(2) = SIZE(pdata_3d,DIM=2) W_F(idf)%W_V(iv)%datasz_in(3) = SIZE(pdata_3d,DIM=3) ENDIF ENDIF !- !-- 5.2 The maximum size of the data will give the size of the buffer !- IF (W_F(idf)%W_V(iv)%datasz_max <= 0) THEN largebuf = .FALSE. DO io=1,W_F(idf)%W_V(iv)%nbopp IF (INDEX(fuchnbout,W_F(idf)%W_V(iv)%sopp(io)) > 0) THEN largebuf = .TRUE. ENDIF ENDDO IF (largebuf) THEN W_F(idf)%W_V(iv)%datasz_max = & & W_F(idf)%W_V(iv)%scsize(1) & & *W_F(idf)%W_V(iv)%scsize(2) & & *W_F(idf)%W_V(iv)%scsize(3) ELSE IF (l1d) THEN W_F(idf)%W_V(iv)%datasz_max = & & W_F(idf)%W_V(iv)%datasz_in(1) ELSE IF (l2d) THEN W_F(idf)%W_V(iv)%datasz_max = & & W_F(idf)%W_V(iv)%datasz_in(1) & & *W_F(idf)%W_V(iv)%datasz_in(2) ELSE IF (l3d) THEN W_F(idf)%W_V(iv)%datasz_max = & & W_F(idf)%W_V(iv)%datasz_in(1) & & *W_F(idf)%W_V(iv)%datasz_in(2) & & *W_F(idf)%W_V(iv)%datasz_in(3) ENDIF ENDIF ENDIF !- IF (.NOT.ALLOCATED(tbf_1)) THEN IF (l_dbg) THEN WRITE(*,*) & & c_nam//" : allocate tbf_1 for size = ", & & W_F(idf)%W_V(iv)%datasz_max ENDIF ALLOCATE(tbf_1(W_F(idf)%W_V(iv)%datasz_max)) ELSE IF (W_F(idf)%W_V(iv)%datasz_max > SIZE(tbf_1)) THEN IF (l_dbg) THEN WRITE(*,*) & & c_nam//" : re-allocate tbf_1 for size = ", & & W_F(idf)%W_V(iv)%datasz_max ENDIF DEALLOCATE(tbf_1) ALLOCATE(tbf_1(W_F(idf)%W_V(iv)%datasz_max)) ENDIF !- !-- We have to do the first operation anyway. !-- Thus we do it here and change the ranke !-- of the data at the same time. This should speed up things. !- nbpt_out = W_F(idf)%W_V(iv)%datasz_max IF (l1d) THEN nbpt_in1 = W_F(idf)%W_V(iv)%datasz_in(1) CALL mathop (W_F(idf)%W_V(iv)%sopp(1),nbpt_in1,pdata_1d, & & missing_val,nbindex,nindex, & & W_F(idf)%W_V(iv)%scal(1),nbpt_out,tbf_1) ELSE IF (l2d) THEN nbpt_in2(1:2) = W_F(idf)%W_V(iv)%datasz_in(1:2) CALL mathop (W_F(idf)%W_V(iv)%sopp(1),nbpt_in2,pdata_2d, & & missing_val,nbindex,nindex, & & W_F(idf)%W_V(iv)%scal(1),nbpt_out,tbf_1) ELSE IF (l3d) THEN nbpt_in3(1:3) = W_F(idf)%W_V(iv)%datasz_in(1:3) CALL mathop (W_F(idf)%W_V(iv)%sopp(1),nbpt_in3,pdata_3d, & & missing_val,nbindex,nindex, & & W_F(idf)%W_V(iv)%scal(1),nbpt_out,tbf_1) ENDIF CALL histwrite_real (idf,iv,pitau,nbpt_out, & & tbf_1,nbindex,nindex,do_oper,do_write) ENDIF !- ! 6.0 Manage time steps !- IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN W_F(idf)%W_V(iv)%last_opp_chk = pitau W_F(idf)%W_V(iv)%last_wrt_chk = pitau ELSE W_F(idf)%W_V(iv)%last_opp_chk = -99 W_F(idf)%W_V(iv)%last_wrt_chk = -99 ENDIF !----------------------- END SUBROUTINE histw_rnd !=== SUBROUTINE histwrite_real & & (idf,iv,pitau,nbdpt,tbf_1,nbindex,nindex,do_oper,do_write) !--------------------------------------------------------------------- !- This subroutine is internal and does the calculations and writing !- if needed. At a later stage it should be split into an operation !- and writing subroutines. !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: idf,pitau,iv, & & nbindex,nindex(nbindex),nbdpt REAL,DIMENSION(:) :: tbf_1 LOGICAL,INTENT(IN) :: do_oper,do_write !- INTEGER :: tsz,nfid,nvid,iret,itax,io,nbin,nbout INTEGER :: nx,ny,nz,ky,kz,kt,kc INTEGER,DIMENSION(4) :: corner,edges INTEGER :: itime !- REAL :: rtime REAL,DIMENSION(2) :: t_bnd CHARACTER(LEN=7) :: tmp_opp REAL,ALLOCATABLE,DIMENSION(:),SAVE :: tbf_2 LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN WRITE(*,*) "histwrite 0.0 : VAR : ",W_F(idf)%W_V(iv)%v_name WRITE(*,*) "histwrite 0.0 : nbindex :",nbindex WRITE(*,*) "histwrite 0.0 : nindex :",nindex(1:MIN(3,nbindex)),'...' ENDIF !- ! The sizes which can be encoutered !- tsz = W_F(idf)%W_V(iv)%zsize(1) & & *W_F(idf)%W_V(iv)%zsize(2) & & *W_F(idf)%W_V(iv)%zsize(3) !- ! 1.0 We allocate and the temporary space needed for operations. ! The buffers are only deallocated when more space is needed. ! This reduces the umber of allocates but increases memory needs. !- IF (.NOT.ALLOCATED(tbf_2)) THEN IF (l_dbg) THEN WRITE(*,*) "histwrite_real 1.1 allocate tbf_2 ",SIZE(tbf_1) ENDIF ALLOCATE(tbf_2(W_F(idf)%W_V(iv)%datasz_max)) ELSE IF (W_F(idf)%W_V(iv)%datasz_max > SIZE(tbf_2)) THEN IF (l_dbg) THEN WRITE(*,*) "histwrite_real 1.2 re-allocate tbf_2 : ", & & SIZE(tbf_1)," instead of ",SIZE(tbf_2) ENDIF DEALLOCATE(tbf_2) ALLOCATE(tbf_2(W_F(idf)%W_V(iv)%datasz_max)) ENDIF !- rtime = pitau*W_F(idf)%deltat tmp_opp = W_F(idf)%W_V(iv)%topp !- ! 3.0 Do the operations or transfer the slab of data into tbf_1 !- IF (l_dbg) THEN WRITE(*,*) "histwrite: 3.0",idf ENDIF !- ! 3.1 DO the Operations only if needed !- IF (do_oper) THEN nbout = nbdpt !- !-- 3.4 We continue the sequence of operations !-- we started in the interface routine !- DO io=2,W_F(idf)%W_V(iv)%nbopp,2 nbin = nbout nbout = W_F(idf)%W_V(iv)%datasz_max CALL mathop(W_F(idf)%W_V(iv)%sopp(io),nbin,tbf_1, & & missing_val,nbindex,nindex,W_F(idf)%W_V(iv)%scal(io), & & nbout,tbf_2) IF (l_dbg) THEN WRITE(*,*) & & "histwrite: 3.4a nbout : ",nbin,nbout,W_F(idf)%W_V(iv)%sopp(io) ENDIF !- nbin = nbout nbout = W_F(idf)%W_V(iv)%datasz_max CALL mathop(W_F(idf)%W_V(iv)%sopp(io+1),nbin,tbf_2, & & missing_val,nbindex,nindex,W_F(idf)%W_V(iv)%scal(io+1), & & nbout,tbf_1) IF (l_dbg) THEN WRITE(*,*) & & "histwrite: 3.4b nbout : ",nbin,nbout,W_F(idf)%W_V(iv)%sopp(io+1) ENDIF ENDDO !- ! 3.5 Zoom into the data !- IF (l_dbg) THEN WRITE(*,*) & & "histwrite: 3.5 size(tbf_1) : ",SIZE(tbf_1) WRITE(*,*) & & "histwrite: 3.5 slab in X :", & & W_F(idf)%W_V(iv)%zorig(1),W_F(idf)%W_V(iv)%zsize(1) WRITE(*,*) & & "histwrite: 3.5 slab in Y :", & & W_F(idf)%W_V(iv)%zorig(2),W_F(idf)%W_V(iv)%zsize(2) WRITE(*,*) & & "histwrite: 3.5 slab in Z :", & & W_F(idf)%W_V(iv)%zorig(3),W_F(idf)%W_V(iv)%zsize(3) WRITE(*,*) & & "histwrite: 3.5 slab of input:", & & W_F(idf)%W_V(iv)%scsize(1), & & W_F(idf)%W_V(iv)%scsize(2), & & W_F(idf)%W_V(iv)%scsize(3) ENDIF !--- !-- We have to consider blocks of contiguous data !--- nx=MAX(W_F(idf)%W_V(iv)%zsize(1),1) ny=MAX(W_F(idf)%W_V(iv)%zsize(2),1) nz=MAX(W_F(idf)%W_V(iv)%zsize(3),1) IF ( (W_F(idf)%W_V(iv)%zorig(1) == 1) & & .AND.( W_F(idf)%W_V(iv)%zsize(1) & & == W_F(idf)%W_V(iv)%scsize(1)) & & .AND.(W_F(idf)%W_V(iv)%zorig(2) == 1) & & .AND.( W_F(idf)%W_V(iv)%zsize(2) & & == W_F(idf)%W_V(iv)%scsize(2))) THEN kt = (W_F(idf)%W_V(iv)%zorig(3)-1)*nx*ny tbf_2(1:nx*ny*nz) = tbf_1(kt+1:kt+nx*ny*nz) ELSEIF ( (W_F(idf)%W_V(iv)%zorig(1) == 1) & & .AND.( W_F(idf)%W_V(iv)%zsize(1) & & == W_F(idf)%W_V(iv)%scsize(1))) THEN kc = -nx*ny DO kz=W_F(idf)%W_V(iv)%zorig(3),W_F(idf)%W_V(iv)%zorig(3)+nz-1 kc = kc+nx*ny kt = ( (kz-1)*W_F(idf)%W_V(iv)%scsize(2) & & +W_F(idf)%W_V(iv)%zorig(2)-1)*nx tbf_2(kc+1:kc+nx*ny) = tbf_1(kt+1:kt+nx*ny) ENDDO ELSE kc = -nx DO kz=W_F(idf)%W_V(iv)%zorig(3),W_F(idf)%W_V(iv)%zorig(3)+nz-1 DO ky=W_F(idf)%W_V(iv)%zorig(2),W_F(idf)%W_V(iv)%zorig(2)+ny-1 kc = kc+nx kt = ((kz-1)*W_F(idf)%W_V(iv)%scsize(2)+ky-1) & & *W_F(idf)%W_V(iv)%scsize(1) & & +W_F(idf)%W_V(iv)%zorig(1)-1 tbf_2(kc+1:kc+nx) = tbf_1(kt+1:kt+nx) ENDDO ENDDO ENDIF !- !-- 4.0 Get the min and max of the field !- IF (l_dbg) THEN WRITE(*,*) "histwrite: 4.0 tbf_1",idf,iv, & & TRIM(tmp_opp),' ---- ',LEN_TRIM(tmp_opp),nbindex ENDIF !- IF (W_F(idf)%W_V(iv)%hist_calc_rng) THEN W_F(idf)%W_V(iv)%hist_minmax(1) = & & MIN(W_F(idf)%W_V(iv)%hist_minmax(1), & & MINVAL(tbf_2(1:tsz),MASK=tbf_2(1:tsz) /= missing_val)) W_F(idf)%W_V(iv)%hist_minmax(2) = & & MAX(W_F(idf)%W_V(iv)%hist_minmax(2), & & MAXVAL(tbf_2(1:tsz),MASK=tbf_2(1:tsz) /= missing_val)) ENDIF !- !-- 5.0 Do the operations if needed. In the case of instantaneous !-- output we do not transfer to the time_buffer. !- IF (l_dbg) THEN WRITE(*,*) "histwrite: 5.0 idf : ",idf," iv : ",iv," tsz : ",tsz ENDIF !- IF ( (TRIM(tmp_opp) /= "inst") & & .AND.(TRIM(tmp_opp) /= "once") ) THEN CALL moycum(tmp_opp,tsz,W_F(idf)%W_V(iv)%t_bf, & & tbf_2,W_F(idf)%W_V(iv)%nb_opp) ENDIF !- W_F(idf)%W_V(iv)%last_opp = pitau W_F(idf)%W_V(iv)%nb_opp = W_F(idf)%W_V(iv)%nb_opp+1 !- ENDIF !- ! 6.0 Write to file if needed !- IF (l_dbg) WRITE(*,*) "histwrite: 6.0",idf !- IF (do_write) THEN !- nfid = W_F(idf)%ncfid nvid = W_F(idf)%W_V(iv)%ncvid !- !-- 6.1 Do the operations that are needed before writting !- IF (l_dbg) WRITE(*,*) "histwrite: 6.1",idf !- IF ( (TRIM(tmp_opp) /= "inst") & & .AND.(TRIM(tmp_opp) /= "once") ) THEN t_bnd(1:2) = (/ W_F(idf)%W_V(iv)%last_wrt*W_F(idf)%deltat,rtime /) rtime = (t_bnd(1)+t_bnd(2))/2.0 ENDIF !- !-- 6.2 Add a value to the time axis of this variable if needed !- IF ( (TRIM(tmp_opp) /= "l_max") & & .AND.(TRIM(tmp_opp) /= "l_min") & & .AND.(TRIM(tmp_opp) /= "once") ) THEN !- IF (l_dbg) WRITE(*,*) "histwrite: 6.2",idf !- itax = W_F(idf)%W_V(iv)%t_axid itime = W_F(idf)%W_V(iv)%nb_wrt+1 !- IF (W_F(idf)%W_V(itax)%tax_last < itime) THEN iret = NF90_PUT_VAR (nfid,W_F(idf)%W_V(itax)%tdimid, & & (/ rtime /),start=(/ itime /),count=(/ 1 /)) IF (W_F(idf)%W_V(itax)%tbndid > 0) THEN iret = NF90_PUT_VAR (nfid,W_F(idf)%W_V(itax)%tbndid, & & t_bnd,start=(/ 1,itime /),count=(/ 2,1 /)) ENDIF W_F(idf)%W_V(itax)%tax_last = itime ENDIF ELSE itime=1 ENDIF !- !-- 6.3 Write the data. Only in the case of instantaneous output ! we do not write the buffer. !- IF (l_dbg) THEN WRITE(*,*) "histwrite: 6.3",idf,nfid,nvid,iv,itime ENDIF !- IF (W_F(idf)%W_V(iv)%scsize(3) == 1) THEN IF (W_F(idf)%regular) THEN corner(1:4) = (/ 1,1,itime,0 /) edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1), & & W_F(idf)%W_V(iv)%zsize(2),1,0 /) ELSE corner(1:4) = (/ 1,itime,0,0 /) edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1),1,0,0 /) ENDIF ELSE IF (W_F(idf)%regular) THEN corner(1:4) = (/ 1,1,1,itime /) edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1), & & W_F(idf)%W_V(iv)%zsize(2), & & W_F(idf)%W_V(iv)%zsize(3),1 /) ELSE corner(1:4) = (/ 1,1,itime,0 /) edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1), & & W_F(idf)%W_V(iv)%zsize(3),1,0 /) ENDIF ENDIF !- IF ( (TRIM(tmp_opp) /= "inst") & & .AND.(TRIM(tmp_opp) /= "once") ) THEN iret = NF90_PUT_VAR (nfid,nvid,W_F(idf)%W_V(iv)%t_bf, & & start=corner(1:4),count=edges(1:4)) ELSE iret = NF90_PUT_VAR (nfid,nvid,tbf_2, & & start=corner(1:4),count=edges(1:4)) ENDIF !- W_F(idf)%W_V(iv)%last_wrt = pitau W_F(idf)%W_V(iv)%nb_wrt = W_F(idf)%W_V(iv)%nb_wrt+1 W_F(idf)%W_V(iv)%nb_opp = 0 !--- ! After the write the file can be synchronized so that no data is ! lost in case of a crash. This feature gives up on the benefits of ! buffering and should only be used in debuging mode. A flag is ! needed here to switch to this mode. !--- ! iret = NF90_SYNC (nfid) !- ENDIF !---------------------------- END SUBROUTINE histwrite_real !=== SUBROUTINE histvar_seq (idf,pvarname,idv) !--------------------------------------------------------------------- !- This subroutine optimize the search for the variable in the table. !- In a first phase it will learn the succession of the variables !- called and then it will use the table to guess what comes next. !- It is the best solution to avoid lengthy searches through array !- vectors. !- !- ARGUMENTS : !- !- idf : id of the file on which we work !- pvarname : The name of the variable we are looking for !- idv : The var id we found !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(in) :: idf CHARACTER(LEN=*),INTENT(IN) :: pvarname INTEGER,INTENT(out) :: idv !- LOGICAL,SAVE :: learning(nb_files_max)=.TRUE. INTEGER,SAVE :: overlap(nb_files_max) = -1 INTEGER,SAVE :: varseq(nb_files_max,nb_var_max*3) INTEGER,SAVE :: varseq_len(nb_files_max) = 0 INTEGER,SAVE :: varseq_pos(nb_files_max) INTEGER,SAVE :: varseq_err(nb_files_max) = 0 INTEGER :: ib,sp,nn,pos CHARACTER(LEN=70) :: str70 LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN WRITE(*,*) 'histvar_seq, start of the subroutine :',learning(idf) ENDIF !- IF (learning(idf)) THEN !- !-- 1.0 We compute the length over which we are going !-- to check the overlap !- IF (overlap(idf) <= 0) THEN IF (W_F(idf)%n_var > 6) THEN overlap(idf) = W_F(idf)%n_var/3*2 ELSE overlap(idf) = W_F(idf)%n_var ENDIF ENDIF !- !-- 1.1 Find the position of this string !- CALL find_str (W_F(idf)%W_V(1:W_F(idf)%n_var)%v_name,pvarname,pos) IF (pos > 0) THEN idv = pos ELSE CALL ipslerr (3,"histvar_seq", & & 'The name of the variable you gave has not been declared', & & 'You should use subroutine histdef for declaring variable', & & TRIM(pvarname)) ENDIF !- !-- 1.2 If we have not given up we store the position !-- in the sequence of calls !- IF (varseq_err(idf) >= 0) THEN sp = varseq_len(idf)+1 IF (sp <= nb_var_max*3) THEN varseq(idf,sp) = idv varseq_len(idf) = sp ELSE CALL ipslerr (2,"histvar_seq",& & 'The learning process has failed and we give up. '// & & 'Either you sequence is',& & 'too complex or I am too dumb. '// & & 'This will only affect the efficiency',& & 'of your code. Thus if you wish to save time'// & & ' contact the IOIPSL team. ') WRITE(*,*) 'The sequence we have found up to now :' WRITE(*,*) varseq(idf,1:sp-1) varseq_err(idf) = -1 ENDIF !- !---- 1.3 Check if we have found the right overlap !- IF (varseq_len(idf) >= overlap(idf)*2) THEN !- !------ We skip a few variables if needed as they could come !------ from the initialisation of the model. !- DO ib = 0,sp-overlap(idf)*2 IF ( learning(idf) .AND.& & SUM(ABS(varseq(idf,ib+1:ib+overlap(idf)) -& & varseq(idf,sp-overlap(idf)+1:sp))) == 0 ) THEN learning(idf) = .FALSE. varseq_len(idf) = sp-overlap(idf)-ib varseq_pos(idf) = overlap(idf)+ib varseq(idf,1:varseq_len(idf)) = & & varseq(idf,ib+1:ib+varseq_len(idf)) ENDIF ENDDO ENDIF ENDIF ELSE !- !-- 2.0 Now we know how the calls to histwrite are sequenced !-- and we can get a guess at the var ID !- nn = varseq_pos(idf)+1 IF (nn > varseq_len(idf)) nn = 1 !- idv = varseq(idf,nn) !- IF (TRIM(W_F(idf)%W_V(idv)%v_name) /= TRIM(pvarname)) THEN CALL find_str (W_F(idf)%W_V(1:W_F(idf)%n_var)%v_name,pvarname,pos) IF (pos > 0) THEN idv = pos ELSE CALL ipslerr (3,"histvar_seq", & & 'The name of the variable you gave has not been declared',& & 'You should use subroutine histdef for declaring variable', & & TRIM(pvarname)) ENDIF varseq_err(idf) = varseq_err(idf)+1 ELSE !- !---- We only keep the new position if we have found the variable !---- this way. This way an out of sequence call to histwrite does !---- not defeat the process. !- varseq_pos(idf) = nn ENDIF !- !!$ IF (varseq_err(idf) >= 10) THEN !!$ WRITE(str70,'("for file ",I3)') idf !!$ CALL ipslerr (2,"histvar_seq", & !!$ & 'There were 10 errors in the learned sequence of variables',& !!$ & str70,'This looks like a bug, please report it.') !!$ varseq_err(idf) = 0 !!$ ENDIF ENDIF !- IF (l_dbg) THEN WRITE(*,*) & & 'histvar_seq, end of the subroutine :',TRIM(pvarname),idv ENDIF !------------------------- END SUBROUTINE histvar_seq !=== SUBROUTINE histsync (idf) !--------------------------------------------------------------------- !- This subroutine will synchronise all !- (or one if defined) opened files. !- !- VERSION !- !--------------------------------------------------------------------- IMPLICIT NONE !- ! idf : optional argument for fileid INTEGER,INTENT(in),OPTIONAL :: idf !- INTEGER :: ifile,iret,i_s,i_e !- LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN WRITE(*,*) "->histsync" ENDIF !- IF (PRESENT(idf)) THEN IF ( (idf >= 1).AND.(idf <= nb_files_max) ) THEN IF (W_F(idf)%ncfid > 0) THEN i_s = idf i_e = idf ELSE i_s = 1 i_e = 0 CALL ipslerr (2,'histsync', & & 'Unable to synchronise the file :','probably','not opened') ENDIF ELSE CALL ipslerr (3,'histsync','Invalid file identifier',' ',' ') ENDIF ELSE i_s = 1 i_e = nb_files_max ENDIF !- DO ifile=i_s,i_e IF (W_F(ifile)%ncfid > 0) THEN IF (l_dbg) THEN WRITE(*,*) ' histsync - synchronising file number ',ifile ENDIF iret = NF90_SYNC(W_F(ifile)%ncfid) ENDIF ENDDO !- IF (l_dbg) THEN WRITE(*,*) "<-histsync" ENDIF !---------------------- END SUBROUTINE histsync !=== SUBROUTINE histclo (idf) !--------------------------------------------------------------------- !- This subroutine will close all (or one if defined) opened files !- !- VERSION !- !--------------------------------------------------------------------- IMPLICIT NONE !- ! idf : optional argument for fileid INTEGER,INTENT(in),OPTIONAL :: idf !- INTEGER :: ifile,nfid,nvid,iret,iv,i_s,i_e LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN WRITE(*,*) "->histclo" ENDIF !- IF (PRESENT(idf)) THEN IF ( (idf >= 1).AND.(idf <= nb_files_max) ) THEN IF (W_F(idf)%ncfid > 0) THEN i_s = idf i_e = idf ELSE i_s = 1 i_e = 0 CALL ipslerr (2,'histclo', & & 'Unable to close the file :','probably','not opened') ENDIF ELSE CALL ipslerr (3,'histclo','Invalid file identifier',' ',' ') ENDIF ELSE i_s = 1 i_e = nb_files_max ENDIF !- DO ifile=i_s,i_e IF (W_F(ifile)%ncfid > 0) THEN IF (l_dbg) THEN WRITE(*,*) ' histclo - closing specified file number :',ifile ENDIF nfid = W_F(ifile)%ncfid iret = NF90_REDEF(nfid) !----- !---- 1. Loop on the number of variables to add some final information !----- IF (l_dbg) THEN WRITE(*,*) ' Entering loop on vars : ',W_F(ifile)%n_var ENDIF DO iv=1,W_F(ifile)%n_var !------ Extrema IF (W_F(ifile)%W_V(iv)%hist_wrt_rng) THEN IF (l_dbg) THEN WRITE(*,*) 'min value for file :',ifile,' var n. :',iv, & & ' is : ',W_F(ifile)%W_V(iv)%hist_minmax(1) WRITE(*,*) 'max value for file :',ifile,' var n. :',iv, & & ' is : ',W_F(ifile)%W_V(iv)%hist_minmax(2) ENDIF IF (W_F(ifile)%W_V(iv)%hist_calc_rng) THEN !---------- Put the min and max values on the file nvid = W_F(ifile)%W_V(iv)%ncvid IF (W_F(ifile)%W_V(iv)%v_typ == hist_r8) THEN iret = NF90_PUT_ATT(nfid,nvid,'valid_min', & & REAL(W_F(ifile)%W_V(iv)%hist_minmax(1),KIND=8)) iret = NF90_PUT_ATT(nfid,nvid,'valid_max', & & REAL(W_F(ifile)%W_V(iv)%hist_minmax(2),KIND=8)) ELSE iret = NF90_PUT_ATT(nfid,nvid,'valid_min', & & REAL(W_F(ifile)%W_V(iv)%hist_minmax(1),KIND=4)) iret = NF90_PUT_ATT(nfid,nvid,'valid_max', & & REAL(W_F(ifile)%W_V(iv)%hist_minmax(2),KIND=4)) ENDIF ENDIF ENDIF !------ Time-Buffers IF (ASSOCIATED(W_F(ifile)%W_V(iv)%t_bf)) THEN DEALLOCATE(W_F(ifile)%W_V(iv)%t_bf) ENDIF !------ Reinitialize the sizes W_F(ifile)%W_V(iv)%datasz_in(:) = -1 W_F(ifile)%W_V(iv)%datasz_max = -1 ENDDO !----- !---- 2. Close the file !----- IF (l_dbg) WRITE(*,*) ' close file :',nfid iret = NF90_CLOSE(nfid) W_F(ifile)%ncfid = -1 W_F(ifile)%dom_id_svg = -1 ENDIF ENDDO !- IF (l_dbg) THEN WRITE(*,*) "<-histclo" ENDIF !--------------------- END SUBROUTINE histclo !=== SUBROUTINE ioconf_modname (str) !--------------------------------------------------------------------- !- This subroutine allows to configure the name !- of the model written into the file !--------------------------------------------------------------------- IMPLICIT NONE !- CHARACTER(LEN=*),INTENT(IN) :: str !--------------------------------------------------------------------- IF (.NOT.lock_modname) THEN model_name = str(1:MIN(LEN_TRIM(str),80)) lock_modname = .TRUE. ELSE CALL ipslerr (2,"ioconf_modname", & & 'The model name can only be changed once and only', & & 'before it is used. It is now set to :',model_name) ENDIF !---------------------------- END SUBROUTINE ioconf_modname !- !=== !- !----------------- END MODULE histcom