PROGRAM flio_rbld ! !$Id: flio_rbld.f90 3680 2012-11-27 14:42:24Z rblod $ !- ! This software is governed by the CeCILL license ! See IOIPSL/IOIPSL_License_CeCILL.txt !!-------------------------------------------------------------------- !! PROGRAM flio_rbld !! !! PURPOSE : !! Recombine the files of MPI version of IOIPSL !! along several dimensions. !! !! CALLING SEQUENCE : !! !! "flio_rbld" is usually invoked by the script "rebuild" !! !! rebuild -h !! !! rebuild [-v lev] [-f] -o outfile infile[1] ... infile[n] !! !! INPUT for "rebuild" : !! !! -h : help !! -v lev : verbosity level !! -f : force executing mode !! -o outfile : name of the recombined file. !! infiles : names of the files that must be recombined. !! !! INPUT for "flio_rbld" : !! !! (I) i_v_lev : verbosity level !! (C) c_force : executing mode (noforce/force) !! (I) f_nb : total number of files !! (C) f_nm(:) : names of the files (input_files output_file) !! !! !! ASSOCIATED MODULES : !! IOIPSL(fliocom) !! !! RESTRICTIONS : !! !! Cases for character are not coded. !! !! Cases for netCDF variables such as array with more !! than 5 dimensions are not coded. !! !! Input files must have the following global attributes : !! !! "DOMAIN_number_total" !! "DOMAIN_number" !! "DOMAIN_dimensions_ids" !! "DOMAIN_size_global" !! "DOMAIN_size_local" !! "DOMAIN_position_first" !! "DOMAIN_position_last" !! "DOMAIN_halo_size_start" !! "DOMAIN_halo_size_end" !! "DOMAIN_type" !! !! NetCDF files must be smaller than 2 Gb. !! !! Character variables should have less than 257 letters !! !! EXAMPLE : !! !! rebuild -v -o sst.nc sst_[0-9][0-9][0-9][0-9].nc !! !! MODIFICATION HISTORY : !! Sebastien Masson (smasson@jamstec.go.jp) March 2004 !! Jacques Bellier (Jacques.Bellier@cea.fr) June 2005 !!-------------------------------------------------------------------- USE IOIPSL USE defprec !- IMPLICIT NONE !- ! Character length INTEGER,PARAMETER :: chlen=256 !- ! DO loops and test related variables INTEGER :: i,ia,id,iv,iw,i_i,i_n INTEGER :: ik,itmin,itmax,it1,it2,it LOGICAL :: l_force,l_uld !- ! Input arguments related variables INTEGER :: i_v_lev CHARACTER(LEN=15) :: c_force INTEGER :: f_nb,f_nb_in CHARACTER(LEN=chlen),DIMENSION(:),ALLOCATABLE :: f_nm !- ! Domains related variables INTEGER :: d_n_t,i_ntd INTEGER,DIMENSION(:),ALLOCATABLE :: dom_att,d_d_i,d_s_g INTEGER,DIMENSION(:,:),ALLOCATABLE :: d_s_l,d_p_f,d_p_l,d_h_s,d_h_e LOGICAL :: l_cgd,l_cof,l_col,l_o_f,l_o_m,l_o_l CHARACTER(LEN=chlen) :: c_d_n !- ! Model files related variables LOGICAL :: l_ocf INTEGER,DIMENSION(:),ALLOCATABLE :: f_a_id INTEGER :: f_id_i1,f_id_i,f_id_o INTEGER :: f_d_nb,f_v_nb,f_a_nb,f_d_ul INTEGER :: v_a_nb,a_type CHARACTER(LEN=chlen),DIMENSION(:),ALLOCATABLE :: & & f_d_nm,f_v_nm,f_a_nm,v_a_nm CHARACTER(LEN=chlen) :: f_u_nm INTEGER,DIMENSION(:),ALLOCATABLE :: v_d_nb,v_d_ul,v_type INTEGER,DIMENSION(:,:),ALLOCATABLE :: v_d_i INTEGER,DIMENSION(:),ALLOCATABLE :: f_d_i,f_d_l INTEGER :: a_l INTEGER,DIMENSION(flio_max_var_dims) :: d_i,ib,ie INTEGER,DIMENSION(:),ALLOCATABLE :: & & io_i,io_n,ia_sf,io_sf,io_cf,ia_sm,io_sm,io_cm,ia_sl,io_sl,io_cl LOGICAL :: l_ex CHARACTER(LEN=chlen) :: c_wn1,c_wn2 !- !?INTEGERS of KIND 1 are not supported on all computers !?INTEGER(KIND=i_1) :: i1_0d !?INTEGER(KIND=i_1),DIMENSION(:),ALLOCATABLE :: i1_1d !?INTEGER(KIND=i_1),DIMENSION(:,:),ALLOCATABLE :: i1_2d !?INTEGER(KIND=i_1),DIMENSION(:,:,:),ALLOCATABLE :: i1_3d !?INTEGER(KIND=i_1),DIMENSION(:,:,:,:),ALLOCATABLE :: i1_4d !?INTEGER(KIND=i_1),DIMENSION(:,:,:,:,:),ALLOCATABLE :: i1_5d INTEGER(KIND=i_2) :: i2_0d INTEGER(KIND=i_2),DIMENSION(:),ALLOCATABLE :: i2_1d INTEGER(KIND=i_2),DIMENSION(:,:),ALLOCATABLE :: i2_2d INTEGER(KIND=i_2),DIMENSION(:,:,:),ALLOCATABLE :: i2_3d INTEGER(KIND=i_2),DIMENSION(:,:,:,:),ALLOCATABLE :: i2_4d INTEGER(KIND=i_2),DIMENSION(:,:,:,:,:),ALLOCATABLE :: i2_5d INTEGER(KIND=i_4) :: i4_0d INTEGER(KIND=i_4),DIMENSION(:),ALLOCATABLE :: i4_1d INTEGER(KIND=i_4),DIMENSION(:,:),ALLOCATABLE :: i4_2d INTEGER(KIND=i_4),DIMENSION(:,:,:),ALLOCATABLE :: i4_3d INTEGER(KIND=i_4),DIMENSION(:,:,:,:),ALLOCATABLE :: i4_4d INTEGER(KIND=i_4),DIMENSION(:,:,:,:,:),ALLOCATABLE :: i4_5d REAL(KIND=r_4) :: r4_0d REAL(KIND=r_4),DIMENSION(:),ALLOCATABLE :: r4_1d REAL(KIND=r_4),DIMENSION(:,:),ALLOCATABLE :: r4_2d REAL(KIND=r_4),DIMENSION(:,:,:),ALLOCATABLE :: r4_3d REAL(KIND=r_4),DIMENSION(:,:,:,:),ALLOCATABLE :: r4_4d REAL(KIND=r_8),DIMENSION(:,:,:,:,:),ALLOCATABLE :: r4_5d REAL(KIND=r_8) :: r8_0d REAL(KIND=r_8),DIMENSION(:),ALLOCATABLE :: r8_1d REAL(KIND=r_8),DIMENSION(:,:),ALLOCATABLE :: r8_2d REAL(KIND=r_8),DIMENSION(:,:,:),ALLOCATABLE :: r8_3d REAL(KIND=r_8),DIMENSION(:,:,:,:),ALLOCATABLE :: r8_4d REAL(KIND=r_8),DIMENSION(:,:,:,:,:),ALLOCATABLE :: r8_5d !- ! elapsed and cpu time computation variables INTEGER :: nb_cc_ini,nb_cc_end,nb_cc_sec,nb_cc_max REAL :: t_cpu_ini,t_cpu_end !--------------------------------------------------------------------- !- !------------------- ! INPUT arguments !------------------- !- ! Retrieve the verbosity level READ (UNIT=*,FMT=*) i_v_lev !- ! Retrieve the executing mode READ (UNIT=*,FMT='(A)') c_force l_force = (TRIM(c_force) == 'force') !- ! Retrieve the number of arguments READ (UNIT=*,FMT=*) f_nb f_nb_in = f_nb-1 !- ! Retrieve the file names ALLOCATE(f_nm(f_nb)) DO iw=1,f_nb READ (UNIT=*,FMT='(A)') f_nm(iw) ENDDO !- ! Allocate and initialize the array of file access identifiers ALLOCATE(f_a_id(f_nb_in)); f_a_id(:) = -1; !- IF (i_v_lev >= 1) THEN WRITE (UNIT=*,FMT='("")') WRITE (UNIT=*,FMT='(" verbosity level : ",I4)') i_v_lev WRITE (UNIT=*,FMT='(" executing mode : ",A)') TRIM(c_force) WRITE (UNIT=*,FMT='(" number of args : ",I4)') f_nb WRITE (UNIT=*,FMT='(" Input files :")') DO iw=1,f_nb_in WRITE (*,'(" ",A)') TRIM(f_nm(iw)) ENDDO WRITE (UNIT=*,FMT='(" Output file :")') WRITE (*,'(" ",A)') TRIM(f_nm(f_nb)) !-- time initializations CALL system_clock & & (count=nb_cc_ini,count_rate=nb_cc_sec,count_max=nb_cc_max) CALL cpu_time (t_cpu_ini) ENDIF !- !--------------------------------------------------- ! Retrieve basic informations from the first file !--------------------------------------------------- !- ! Open the first file CALL flrb_of (1,f_id_i) !- ! Get the attribute "DOMAIN_number_total" CALL fliogeta (f_id_i,"?","DOMAIN_number_total",d_n_t) !- ! Validate the number of input files : ! should be equal to the total number ! of domains used in the simulation IF (d_n_t /= f_nb_in) THEN IF (l_force) THEN iw = 2 ELSE iw = 3 DEALLOCATE(f_nm,f_a_id) CALL flrb_cf (1,.TRUE.) ENDIF CALL ipslerr (iw,"flio_rbld", & & "The number of input files", & & "is not equal to the number of DOMAINS"," ") ENDIF !- ! Retrieve the basic characteristics of the first input file CALL flioinqf & & (f_id_i,nb_dim=f_d_nb,nb_var=f_v_nb,nb_gat=f_a_nb,id_uld=f_d_ul) !- ! Build the list of the names of the ! dimensions/variables/global_attributes and retrieve ! the unlimited_dimension name from the first input file ALLOCATE(f_d_nm(f_d_nb),f_v_nm(f_v_nb),f_a_nm(f_a_nb)) CALL flioinqn (f_id_i,cn_dim=f_d_nm,cn_var=f_v_nm, & & cn_gat=f_a_nm,cn_uld=f_u_nm) !- ! Build the list of the dimensions identifiers and lengths ALLOCATE(f_d_i(f_d_nb),f_d_l(f_d_nb)) CALL flioinqf (f_id_i,id_dim=f_d_i,ln_dim=f_d_l) !- ! Close the file CALL flrb_cf (1,.FALSE.) !- ! Check if the number of needed files is greater than ! the maximum number of simultaneously opened files. ! In that case, open and close model files for each reading, ! otherwise keep the "flio" identifiers of the opened files. l_ocf = (f_nb > flio_max_files) !- !---------------------------------------------------- ! Retrieve domain informations for each input file !---------------------------------------------------- !- DO iw=1,f_nb_in !--- CALL flrb_of (iw,f_id_i) !--- IF (iw > 1) THEN c_wn1 = "DOMAIN_number_total" CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) IF (l_ex) THEN CALL fliogeta (f_id_i,"?",TRIM(c_wn1),i_ntd) IF (i_ntd /= d_n_t) THEN CALL ipslerr (3,"flio_rbld", & & "File : "//TRIM(f_nm(iw)), & & "Attribute : "//TRIM(c_wn1), & & "not equal to the one of the first file") ENDIF ELSE CALL ipslerr (3,"flio_rbld", & & "File : "//TRIM(f_nm(iw)), & & "Attribute : "//TRIM(c_wn1),"not found") ENDIF ENDIF !--- c_wn1 = "DOMAIN_dimensions_ids" CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) IF (l_ex) THEN ALLOCATE(dom_att(a_l)) CALL fliogeta (f_id_i,"?",TRIM(c_wn1),dom_att) IF (iw == 1) THEN IF (ANY(dom_att(:) == f_d_ul)) THEN CALL ipslerr (3,"flio_rbld", & & "File : "//TRIM(f_nm(iw)), & & "Attribute : "//TRIM(c_wn1), & & "contains the unlimited dimension") ENDIF ALLOCATE (d_d_i(a_l)) d_d_i(:) = dom_att(:) ELSEIF (SIZE(dom_att) /= SIZE(d_d_i)) THEN CALL ipslerr (3,"flio_rbld", & & "File : "//TRIM(f_nm(iw)), & & "size of the attribute : "//TRIM(c_wn1), & & "not equal to the one of the first file") ELSEIF (ANY(dom_att(:) /= d_d_i(:))) THEN CALL ipslerr (3,"flio_rbld", & & "File : "//TRIM(f_nm(iw)), & & "Attribute : "//TRIM(c_wn1), & & "not equal to the one of the first file") ENDIF DEALLOCATE(dom_att) ELSE CALL ipslerr (3,"flio_rbld", & & "File : "//TRIM(f_nm(iw)), & & "Attribute : "//TRIM(c_wn1),"not found") ENDIF !--- c_wn1 = "DOMAIN_size_global" CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) IF (l_ex) THEN IF (a_l /= SIZE(d_d_i)) THEN CALL ipslerr (3,"flio_rbld", & & "File : "//TRIM(f_nm(iw)), & & "size of the attribute : "//TRIM(c_wn1), & & "not equal to the size of DOMAIN_dimensions_ids") ELSE ALLOCATE(dom_att(a_l)) CALL fliogeta (f_id_i,"?",TRIM(c_wn1),dom_att) IF (iw == 1) THEN ALLOCATE (d_s_g(a_l)) d_s_g(:)=dom_att(:) ELSEIF (ANY(dom_att(:) /= d_s_g(:))) THEN CALL ipslerr (3,"flio_rbld", & & "File : "//TRIM(f_nm(iw)), & & "Attribute : "//TRIM(c_wn1), & & "not equal to the one of the first file") ENDIF DEALLOCATE(dom_att) ENDIF ELSE CALL ipslerr (3,"flio_rbld", & & "File : "//TRIM(f_nm(iw)), & & "Attribute : "//TRIM(c_wn1),"not found") ENDIF !--- c_wn1 = "DOMAIN_size_local" CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) IF (l_ex) THEN IF (a_l /= SIZE(d_d_i)) THEN CALL ipslerr (3,"flio_rbld", & & "File : "//TRIM(f_nm(iw)), & & "size of the attribute : "//TRIM(c_wn1), & & "not equal to the size of DOMAIN_dimensions_ids") ELSE ALLOCATE(dom_att(a_l)) CALL fliogeta (f_id_i,"?",TRIM(c_wn1),dom_att) IF (iw == 1) THEN ALLOCATE (d_s_l(a_l,f_nb_in)) ENDIF d_s_l(:,iw)=dom_att(:) DEALLOCATE(dom_att) ENDIF ELSE CALL ipslerr (3,"flio_rbld", & & "File : "//TRIM(f_nm(iw)), & & "Attribute : "//TRIM(c_wn1),"not found") ENDIF !--- c_wn1 = "DOMAIN_position_first" CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) IF (l_ex) THEN IF (a_l /= SIZE(d_d_i)) THEN CALL ipslerr (3,"flio_rbld", & & "File : "//TRIM(f_nm(iw)), & & "size of the attribute : "//TRIM(c_wn1), & & "not equal to the size of DOMAIN_dimensions_ids") ELSE ALLOCATE(dom_att(a_l)) CALL fliogeta (f_id_i,"?",TRIM(c_wn1),dom_att) IF (iw == 1) THEN ALLOCATE (d_p_f(a_l,f_nb_in)) ENDIF d_p_f(:,iw)=dom_att(:) DEALLOCATE(dom_att) ENDIF ELSE CALL ipslerr (3,"flio_rbld", & & "File : "//TRIM(f_nm(iw)), & & "Attribute : "//TRIM(c_wn1),"not found") ENDIF !--- c_wn1 = "DOMAIN_position_last" CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) IF (l_ex) THEN IF (a_l /= SIZE(d_d_i)) THEN CALL ipslerr (3,"flio_rbld", & & "File : "//TRIM(f_nm(iw)), & & "size of the attribute : "//TRIM(c_wn1), & & "not equal to the size of DOMAIN_dimensions_ids") ELSE ALLOCATE(dom_att(a_l)) CALL fliogeta (f_id_i,"?",TRIM(c_wn1),dom_att) IF (iw == 1) THEN ALLOCATE (d_p_l(a_l,f_nb_in)) ENDIF d_p_l(:,iw)=dom_att(:) DEALLOCATE(dom_att) ENDIF ELSE CALL ipslerr (3,"flio_rbld", & & "File : "//TRIM(f_nm(iw)), & & "Attribute : "//TRIM(c_wn1),"not found") ENDIF !--- c_wn1 = "DOMAIN_halo_size_start" CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) IF (l_ex) THEN IF (a_l /= SIZE(d_d_i)) THEN CALL ipslerr (3,"flio_rbld", & & "File : "//TRIM(f_nm(iw)), & & "size of the attribute : "//TRIM(c_wn1), & & "not equal to the size of DOMAIN_dimensions_ids") ELSE ALLOCATE(dom_att(a_l)) CALL fliogeta (f_id_i,"?",TRIM(c_wn1),dom_att) IF (iw == 1) THEN ALLOCATE (d_h_s(a_l,f_nb_in)) ENDIF d_h_s(:,iw)=dom_att(:) DEALLOCATE(dom_att) ENDIF ELSE CALL ipslerr (3,"flio_rbld", & & "File : "//TRIM(f_nm(iw)), & & "Attribute : "//TRIM(c_wn1),"not found") ENDIF !--- c_wn1 = "DOMAIN_halo_size_end" CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) IF (l_ex) THEN IF (a_l /= SIZE(d_d_i)) THEN CALL ipslerr (3,"flio_rbld", & & "File : "//TRIM(f_nm(iw)), & & "size of the attribute : "//TRIM(c_wn1), & & "not equal to the size of DOMAIN_dimensions_ids") ELSE ALLOCATE(dom_att(a_l)) CALL fliogeta (f_id_i,"?",TRIM(c_wn1),dom_att) IF (iw == 1) THEN ALLOCATE (d_h_e(a_l,f_nb_in)) ENDIF d_h_e(:,iw)=dom_att(:) DEALLOCATE(dom_att) ENDIF ELSE CALL ipslerr (3,"flio_rbld", & & "File : "//TRIM(f_nm(iw)), & & "Attribute : "//TRIM(c_wn1),"not found") ENDIF !--- c_wn1 = "DOMAIN_type" c_wn2 = " " CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) IF (l_ex) THEN CALL fliogeta (f_id_i,"?",TRIM(c_wn1),c_wn2) CALL strlowercase (c_wn2) IF (iw == 1) THEN IF ( (TRIM(c_wn2) == "box") & & .OR.(TRIM(c_wn2) == "apple") ) THEN c_d_n = c_wn2 ELSE CALL ipslerr (3,"flio_rbld", & & "File : "//TRIM(f_nm(iw)), & & "Attribute : "//TRIM(c_wn1), & & "type "//TRIM(c_wn2)//" not (yet) supported") ENDIF ELSEIF (TRIM(c_wn2) /= TRIM(c_d_n)) THEN CALL ipslerr (3,"flio_rbld", & & "File : "//TRIM(f_nm(iw)), & & "Attribute : "//TRIM(c_wn1), & & "not equal to the one of the first file") ENDIF ELSE CALL ipslerr (3,"flio_rbld", & & "File : "//TRIM(f_nm(iw)), & & "Attribute : "//TRIM(c_wn1),"not found") ENDIF !--- CALL flrb_cf (iw,l_ocf) !--- ENDDO !- IF (i_v_lev >= 2) THEN WRITE (UNIT=*,FMT='("")') WRITE (*,'(" From the first file : ")') WRITE (*,'(" Number of dimensions : ",I2)') f_d_nb WRITE (*,'(" Idents : ",(10(1X,I4),:))') f_d_i(1:f_d_nb) WRITE (*,'(" Lengths : ",(10(1X,I4),:))') f_d_l(1:f_d_nb) WRITE (*,'(" Names: ")') DO i=1,f_d_nb WRITE (*,'(" """,A,"""")') TRIM(f_d_nm(i)) ENDDO IF (f_d_ul > 0) THEN WRITE (*,'(" Unlimited dimension id : ",I2)') f_d_i(f_d_ul) ENDIF WRITE (*,'(" Number of variables : ",I2)') f_v_nb WRITE (*,'(" Names: ")') DO i=1,f_v_nb WRITE (*,'(" """,A,"""")') TRIM(f_v_nm(i)) ENDDO WRITE (*,'(" Number of global attributes : ",I2)') f_a_nb WRITE (*,'(" Names: ")') DO i=1,f_a_nb WRITE (*,'(" """,A,"""")') TRIM(f_a_nm(i)) ENDDO ENDIF IF (i_v_lev >= 3) THEN WRITE (UNIT=*,FMT='("")') WRITE (*,'(" From input files : ")') WRITE (*,'(" Total number of DOMAINS : ",I4)') d_n_t WRITE (*,'(" DOMAIN_dimensions_ids :",(10(1X,I5),:))') d_d_i(:) WRITE (*,'(" DOMAIN_size_global :",(10(1X,I5),:))') d_s_g(:) WRITE (*,'(" DOMAIN_type : """,(A),"""")') TRIM(c_d_n) DO iw=1,f_nb_in WRITE (*,'(" File : ",A)') TRIM(f_nm(iw)) WRITE (*,'(" d_s_l :",(10(1X,I5),:))') d_s_l(:,iw) WRITE (*,'(" d_p_f :",(10(1X,I5),:))') d_p_f(:,iw) WRITE (*,'(" d_p_l :",(10(1X,I5),:))') d_p_l(:,iw) WRITE (*,'(" d_h_s :",(10(1X,I5),:))') d_h_s(:,iw) IF (TRIM(c_d_n) == "apple") THEN IF (COUNT(d_h_s(:,iw) /= 0) > 1) THEN CALL ipslerr (3,"flio_rbld", & & "Beginning offset is not yet supported", & & "for more than one dimension"," ") ENDIF ENDIF WRITE (*,'(" d_h_e :",(10(1X,I5),:))') d_h_e(:,iw) IF (TRIM(c_d_n) == "apple") THEN IF (COUNT(d_h_e(:,iw) /= 0) > 1) THEN CALL ipslerr (3,"flio_rbld", & & "Ending offset is not yet supported", & & "for more than one dimension"," ") ENDIF ENDIF ENDDO ENDIF !- !--------------------------------------- ! Create the dimensionned output file !--------------------------------------- !- ! Define the dimensions used in the output file DO id=1,f_d_nb DO i=1,SIZE(d_d_i) IF (f_d_i(id) == d_d_i(i)) THEN f_d_l(id) = d_s_g(i) ENDIF ENDDO ENDDO !- IF (f_d_ul > 0) THEN i = f_d_l(f_d_ul); f_d_l(f_d_ul) = -1; ENDIF !- ! Create the output file CALL fliocrfd (TRIM(f_nm(f_nb)),f_d_nm,f_d_l,f_id_o,c_f_n=c_wn1) !- IF (f_d_ul > 0) THEN f_d_l(f_d_ul) = i; itmin = 1; itmax = f_d_l(f_d_ul); ELSE itmin = 1; itmax = 1; ENDIF !- ! open the first input file used to build the output file !- CALL flrb_of (1,f_id_i1) !- ! define the global attributes in the output file ! copy all global attributes except those beginning by "DOMAIN_" ! eventually actualize the "file_name" attribute !- DO ia=1,f_a_nb IF (INDEX(TRIM(f_a_nm(ia)),"DOMAIN_") == 1) CYCLE IF (TRIM(f_a_nm(ia)) == "file_name") THEN CALL flioputa (f_id_o,"?",TRIM(f_a_nm(ia)),TRIM(c_wn1)) ELSE CALL fliocpya (f_id_i1,"?",TRIM(f_a_nm(ia)),f_id_o,"?") ENDIF ENDDO !- ! define the variables in the output file !- ALLOCATE(v_d_nb(f_v_nb)); v_d_nb(:) = 0; ALLOCATE(v_d_ul(f_v_nb)); v_d_ul(:) = 0; ALLOCATE(v_type(f_v_nb),v_d_i(flio_max_var_dims,f_v_nb)); DO iv=1,f_v_nb !-- get variable informations CALL flioinqv & & (f_id_i1,TRIM(f_v_nm(iv)),l_ex,v_t=v_type(iv), & & nb_dims=v_d_nb(iv),id_dims=d_i,nb_atts=v_a_nb) !-- define the new variable IF (v_d_nb(iv) == 0) THEN CALL fliodefv & & (f_id_o,TRIM(f_v_nm(iv)),v_t=v_type(iv)) ELSE CALL fliodefv & & (f_id_o,TRIM(f_v_nm(iv)),d_i(1:v_d_nb(iv)),v_t=v_type(iv)) DO iw=1,v_d_nb(iv) IF (f_d_ul > 0) THEN IF (d_i(iw) == f_d_ul) THEN v_d_ul(iv) = iw ENDIF ENDIF ENDDO v_d_i(1:v_d_nb(iv),iv) = d_i(1:v_d_nb(iv)) ENDIF !-- copy all variable attributes IF (v_a_nb > 0) THEN ALLOCATE(v_a_nm(v_a_nb)) CALL flioinqv (f_id_i1,TRIM(f_v_nm(iv)),l_ex,cn_atts=v_a_nm) DO ia=1,v_a_nb CALL fliocpya & & (f_id_i1,TRIM(f_v_nm(iv)),TRIM(v_a_nm(ia)), & & f_id_o,TRIM(f_v_nm(iv))) ENDDO DEALLOCATE(v_a_nm) ENDIF ENDDO !- ! update valid_min valid_max attributes values !- CALL flrb_rg !- !------------------------ ! Fill the output file !------------------------ !- DO ik=1,2 l_uld = (ik /= 1) IF (l_uld) THEN it1=itmin; it2=itmax; ELSE it1=1; it2=1; ENDIF DO it=it1,it2 DO iv=1,f_v_nb IF ( (.NOT.l_uld.AND.(v_d_ul(iv) > 0)) & & .OR.(l_uld.AND.(v_d_ul(iv) <= 0)) ) THEN CYCLE ENDIF IF (i_v_lev >= 3) THEN WRITE (UNIT=*,FMT='("")') IF (l_uld) THEN WRITE (UNIT=*,FMT=*) "time step : ",it ENDIF WRITE (UNIT=*,FMT=*) "variable : ",TRIM(f_v_nm(iv)) WRITE (UNIT=*,FMT=*) "var unlim dim : ",v_d_ul(iv) ENDIF !------ do the variable contains dimensions to be recombined ? l_cgd = .FALSE. i_n = 1 DO i=1,SIZE(d_d_i) l_cgd = ANY(v_d_i(1:v_d_nb(iv),iv) == d_d_i(i)) l_cgd = l_cgd.AND.ANY(d_s_l(i,1:f_nb_in) /= d_s_g(i)) IF (l_cgd) THEN i_n = f_nb_in EXIT ENDIF ENDDO IF (v_d_nb(iv) > 0) THEN !-------- Allocate io_i,io_n,ia_sm,io_sm,io_cm i = v_d_nb(iv) ALLOCATE(io_i(i),io_n(i),ia_sm(i),io_sm(i),io_cm(i)) !-------- Default definition of io_i,io_n,io_sm,io_cm io_i(:) = 1; io_n(:) = f_d_l(v_d_i(1:v_d_nb(iv),iv)); ia_sm(:) = 1; io_sm(:) = 1; IF (v_d_ul(iv) > 0) THEN io_i(v_d_ul(iv))=it io_n(v_d_ul(iv))=1 io_sm(v_d_ul(iv))=it ENDIF io_cm(:) = io_n(:); !-------- If needed, allocate offset l_o_f = .FALSE.; l_o_m = .TRUE.; l_o_l = .FALSE.; IF (TRIM(c_d_n) == "apple") THEN ALLOCATE(ia_sf(i),io_sf(i),io_cf(i)) ALLOCATE(ia_sl(i),io_sl(i),io_cl(i)) ia_sf(:) = 1; io_sf(:) = 1; io_cf(:) = io_n(:); ia_sl(:) = 1; io_sl(:) = 1; io_cl(:) = io_n(:); IF (v_d_ul(iv) > 0) THEN io_sf(v_d_ul(iv))=it io_sl(v_d_ul(iv))=it ENDIF ENDIF !-------- Initialize to zero variables data ! approximate dimension IF ( it == 1 .AND. l_cgd) THEN ! Enter I*J I*J is larger thant total number of single files if ( ((f_d_l(1)/(d_s_l(1,1)-3)) * (f_d_l(2)/(d_s_l(2,1)-3) )) .gt. d_n_t ) then CALL ZeroFill (f_id_o, f_v_nm(iv), f_d_l, v_d_nb(iv), v_type(iv), v_d_i(1:v_d_nb(iv),iv)) endif ENDIF ENDIF !------ DO i_i=1,i_n IF (l_cgd) THEN !---------- the variable contains dimensions to be recombined !----------- !---------- open each file containing a small piece of data CALL flrb_of (i_i,f_id_i) !----------- !---------- do the variable has offset at first/last block ? l_cof = .FALSE.; l_col = .FALSE.; IF (TRIM(c_d_n) == "apple") THEN L_BF: DO id=1,v_d_nb(iv) DO i=1,SIZE(d_d_i) IF (v_d_i(id,iv) == d_d_i(i)) THEN l_cof = (d_h_s(i,i_i) /= 0) IF (l_cof) EXIT L_BF ENDIF ENDDO ENDDO L_BF L_BL: DO id=1,v_d_nb(iv) DO i=1,SIZE(d_d_i) IF (v_d_i(id,iv) == d_d_i(i)) THEN l_col = (d_h_e(i,i_i) /= 0) IF (l_col) EXIT L_BL ENDIF ENDDO ENDDO L_BL ENDIF !---------- if needed, redefine start and count for dimensions l_o_f = .FALSE.; l_o_m = .TRUE.; l_o_l = .FALSE.; DO id=1,v_d_nb(iv) DO i=1,SIZE(d_d_i) IF (v_d_i(id,iv) == d_d_i(i)) THEN io_n(id) = d_p_l(i,i_i)-d_p_f(i,i_i)+1 ia_sm(id) = 1 io_sm(id) = d_p_f(i,i_i) io_cm(id) = io_n(id) IF (TRIM(c_d_n) == "box") THEN ia_sm(id) = ia_sm(id)+d_h_s(i,i_i) io_sm(id) = io_sm(id)+d_h_s(i,i_i) io_cm(id) = io_cm(id)-d_h_s(i,i_i)-d_h_e(i,i_i) ELSEIF (TRIM(c_d_n) == "apple") THEN IF (l_cof) THEN IF (d_h_s(i,i_i) /= 0) THEN ia_sf(id) = 1+d_h_s(i,i_i) io_sf(id) = d_p_f(i,i_i)+d_h_s(i,i_i) io_cf(id) = io_n(id)-d_h_s(i,i_i) ELSE io_sf(id) = d_p_f(i,i_i) io_cf(id) = 1 ia_sm(id) = ia_sm(id)+1 io_sm(id) = io_sm(id)+1 io_cm(id) = io_cm(id)-1 l_o_f = .TRUE. ENDIF ENDIF IF (l_col) THEN IF (d_h_e(i,i_i) /= 0) THEN ia_sl(id) = 1 io_sl(id) = d_p_f(i,i_i) io_cl(id) = io_n(id)-d_h_e(i,i_i) ELSE io_cm(id) = io_cm(id)-1 ia_sl(id) = 1+io_n(id)-1 io_sl(id) = d_p_f(i,i_i)+io_n(id)-1 io_cl(id) = 1 l_o_l = .TRUE. ENDIF ENDIF ENDIF ENDIF ENDDO ENDDO l_o_m = ALL(io_cm > 0) ELSE !---------- the data can be read/write in one piece f_id_i = f_id_i1 ENDIF !--------- IF (i_v_lev >= 3) THEN WRITE (UNIT=*,FMT=*) & & TRIM(f_nm(i_i))//" - "//TRIM(f_v_nm(iv)) WRITE (UNIT=*,FMT=*) "io_i : ",io_i(:) WRITE (UNIT=*,FMT=*) "io_n : ",io_n(:) WRITE (UNIT=*,FMT=*) "l_o_f : ",l_o_f IF (l_o_f) THEN WRITE (UNIT=*,FMT=*) "ia_sf : ",ia_sf(:) WRITE (UNIT=*,FMT=*) "io_sf : ",io_sf(:) WRITE (UNIT=*,FMT=*) "io_cf : ",io_cf(:) ENDIF WRITE (UNIT=*,FMT=*) "l_o_m : ",l_o_m IF (l_o_m) THEN WRITE (UNIT=*,FMT=*) "ia_sm : ",ia_sm(:) WRITE (UNIT=*,FMT=*) "io_sm : ",io_sm(:) WRITE (UNIT=*,FMT=*) "io_cm : ",io_cm(:) ENDIF WRITE (UNIT=*,FMT=*) "l_o_l : ",l_o_l IF (l_o_l) THEN WRITE (UNIT=*,FMT=*) "ia_sl : ",ia_sl(:) WRITE (UNIT=*,FMT=*) "io_sl : ",io_sl(:) WRITE (UNIT=*,FMT=*) "io_cl : ",io_cl(:) ENDIF ENDIF !--------- !-------- Cases according to the type, shape and offsets of the data !--------- SELECT CASE (v_type(iv)) !?INTEGERS of KIND 1 are not supported on all computers !? CASE (flio_i1) !--- INTEGER 1 !? SELECT CASE (v_d_nb(iv)) !? CASE (0) !--- Scalar !? CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i1_0d) !? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)),i1_0d) !? CASE (1) !--- 1d array !? ALLOCATE(i1_1d(io_n(1))) !? CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i1_1d, & !? & start=io_i(:),count=io_n(:)) !? IF (l_o_f) THEN !? ib(1:1) = ia_sf(1:1); ie(1:1) = ib(1:1)+io_cf(1:1)-1; !? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & !? & i1_1d(ib(1):ie(1)), & !? & start=io_sf(:),count=io_cf(:)) !? ENDIF !? IF (l_o_m) THEN !? ib(1:1) = ia_sm(1:1); ie(1:1) = ib(1:1)+io_cm(1:1)-1; !? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & !? & i1_1d(ib(1):ie(1)), & !? & start=io_sm(:),count=io_cm(:)) !? ENDIF !? IF (l_o_l) THEN !? ib(1:1) = ia_sl(1:1); ie(1:1) = ib(1:1)+io_cl(1:1)-1; !? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & !? & i1_1d(ib(1):ie(1)), & !? & start=io_sl(:),count=io_cl(:)) !? ENDIF !? DEALLOCATE(i1_1d) !? CASE (2) !--- 2d array !? ALLOCATE(i1_2d(io_n(1),io_n(2))) !? CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i1_2d, & !? & start=io_i(:),count=io_n(:)) !? IF (l_o_f) THEN !? ib(1:2) = ia_sf(1:2); ie(1:2) = ib(1:2)+io_cf(1:2)-1; !? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & !? & i1_2d(ib(1):ie(1),ib(2):ie(2)), & !? & start=io_sf(:),count=io_cf(:)) !? ENDIF !? IF (l_o_m) THEN !? ib(1:2) = ia_sm(1:2); ie(1:2) = ib(1:2)+io_cm(1:2)-1; !? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & !? & i1_2d(ib(1):ie(1),ib(2):ie(2)), & !? & start=io_sm(:),count=io_cm(:)) !? ENDIF !? IF (l_o_l) THEN !? ib(1:2) = ia_sl(1:2); ie(1:2) = ib(1:2)+io_cl(1:2)-1; !? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & !? & i1_2d(ib(1):ie(1),ib(2):ie(2)), & !? & start=io_sl(:),count=io_cl(:)) !? ENDIF !? DEALLOCATE(i1_2d) !? CASE (3) !--- 3d array !? ALLOCATE(i1_3d(io_n(1),io_n(2),io_n(3))) !? CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i1_3d, & !? & start=io_i(:),count=io_n(:)) !? IF (l_o_f) THEN !? ib(1:3) = ia_sf(1:3); ie(1:3) = ib(1:3)+io_cf(1:3)-1; !? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & !? & i1_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & !? & start=io_sf(:),count=io_cf(:)) !? ENDIF !? IF (l_o_m) THEN !? ib(1:3) = ia_sm(1:3); ie(1:3) = ib(1:3)+io_cm(1:3)-1; !? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & !? & i1_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & !? & start=io_sm(:),count=io_cm(:)) !? ENDIF !? IF (l_o_l) THEN !? ib(1:3) = ia_sl(1:3); ie(1:3) = ib(1:3)+io_cl(1:3)-1; !? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & !? & i1_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & !? & start=io_sl(:),count=io_cl(:)) !? ENDIF !? DEALLOCATE(i1_3d) !? CASE (4) !--- 4d array !? ALLOCATE(i1_4d(io_n(1),io_n(2),io_n(3),io_n(4))) !? CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i1_4d, & !? & start=io_i(:),count=io_n(:)) !? IF (l_o_f) THEN !? ib(1:4) = ia_sf(1:4); ie(1:4) = ib(1:4)+io_cf(1:4)-1; !? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & !? & i1_4d(ib(1):ie(1),ib(2):ie(2), & !? & ib(3):ie(3),ib(4):ie(4)), & !? & start=io_sf(:),count=io_cf(:)) !? ENDIF !? IF (l_o_m) THEN !? ib(1:4) = ia_sm(1:4); ie(1:4) = ib(1:4)+io_cm(1:4)-1; !? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & !? & i1_4d(ib(1):ie(1),ib(2):ie(2), & !? & ib(3):ie(3),ib(4):ie(4)), & !? & start=io_sm(:),count=io_cm(:)) !? ENDIF !? IF (l_o_l) THEN !? ib(1:4) = ia_sl(1:4); ie(1:4) = ib(1:4)+io_cl(1:4)-1; !? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & !? & i1_4d(ib(1):ie(1),ib(2):ie(2), & !? & ib(3):ie(3),ib(4):ie(4)), & !? & start=io_sl(:),count=io_cl(:)) !? ENDIF !? DEALLOCATE(i1_4d) !? CASE (5) !--- 5d array !? ALLOCATE(i1_5d(io_n(1),io_n(2),io_n(3),io_n(4),io_n(5))) !? CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i1_5d, & !? & start=io_i(:),count=io_n(:)) !? IF (l_o_f) THEN !? ib(1:5) = ia_sf(1:5); ie(1:5) = ib(1:5)+io_cf(1:5)-1; !? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & !? & i1_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & !? & ib(4):ie(4),ib(5):ie(5)), & !? & start=io_sf(:),count=io_cf(:)) !? ENDIF !? IF (l_o_m) THEN !? ib(1:5) = ia_sm(1:5); ie(1:5) = ib(1:5)+io_cm(1:5)-1; !? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & !? & i1_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & !? & ib(4):ie(4),ib(5):ie(5)), & !? & start=io_sm(:),count=io_cm(:)) !? ENDIF !? IF (l_o_l) THEN !? ib(1:5) = ia_sl(1:5); ie(1:5) = ib(1:5)+io_cl(1:5)-1; !? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & !? & i1_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & !? & ib(4):ie(4),ib(5):ie(5)), & !? & start=io_sl(:),count=io_cl(:)) !? ENDIF !? DEALLOCATE(i1_5d) !? END SELECT !? CASE (flio_i2) !--- INTEGER 2 CASE (flio_i1,flio_i2) !--- INTEGER 1/INTEGER 2 SELECT CASE (v_d_nb(iv)) CASE (0) !--- Scalar CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i2_0d) CALL flioputv (f_id_o,TRIM(f_v_nm(iv)),i2_0d) CASE (1) !--- 1d array ALLOCATE(i2_1d(io_n(1))) CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i2_1d, & & start=io_i(:),count=io_n(:)) IF (l_o_f) THEN ib(1:1) = ia_sf(1:1); ie(1:1) = ib(1:1)+io_cf(1:1)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i2_1d(ib(1):ie(1)), & & start=io_sf(:),count=io_cf(:)) ENDIF IF (l_o_m) THEN ib(1:1) = ia_sm(1:1); ie(1:1) = ib(1:1)+io_cm(1:1)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i2_1d(ib(1):ie(1)), & & start=io_sm(:),count=io_cm(:)) ENDIF IF (l_o_l) THEN ib(1:1) = ia_sl(1:1); ie(1:1) = ib(1:1)+io_cl(1:1)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i2_1d(ib(1):ie(1)), & & start=io_sl(:),count=io_cl(:)) ENDIF DEALLOCATE(i2_1d) CASE (2) !--- 2d array ALLOCATE(i2_2d(io_n(1),io_n(2))) CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i2_2d, & & start=io_i(:),count=io_n(:)) IF (l_o_f) THEN ib(1:2) = ia_sf(1:2); ie(1:2) = ib(1:2)+io_cf(1:2)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i2_2d(ib(1):ie(1),ib(2):ie(2)), & & start=io_sf(:),count=io_cf(:)) ENDIF IF (l_o_m) THEN ib(1:2) = ia_sm(1:2); ie(1:2) = ib(1:2)+io_cm(1:2)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i2_2d(ib(1):ie(1),ib(2):ie(2)), & & start=io_sm(:),count=io_cm(:)) ENDIF IF (l_o_l) THEN ib(1:2) = ia_sl(1:2); ie(1:2) = ib(1:2)+io_cl(1:2)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i2_2d(ib(1):ie(1),ib(2):ie(2)), & & start=io_sl(:),count=io_cl(:)) ENDIF DEALLOCATE(i2_2d) CASE (3) !--- 3d array ALLOCATE(i2_3d(io_n(1),io_n(2),io_n(3))) CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i2_3d, & & start=io_i(:),count=io_n(:)) IF (l_o_f) THEN ib(1:3) = ia_sf(1:3); ie(1:3) = ib(1:3)+io_cf(1:3)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i2_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & & start=io_sf(:),count=io_cf(:)) ENDIF IF (l_o_m) THEN ib(1:3) = ia_sm(1:3); ie(1:3) = ib(1:3)+io_cm(1:3)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i2_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & & start=io_sm(:),count=io_cm(:)) ENDIF IF (l_o_l) THEN ib(1:3) = ia_sl(1:3); ie(1:3) = ib(1:3)+io_cl(1:3)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i2_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & & start=io_sl(:),count=io_cl(:)) ENDIF DEALLOCATE(i2_3d) CASE (4) !--- 4d array ALLOCATE(i2_4d(io_n(1),io_n(2),io_n(3),io_n(4))) CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i2_4d, & & start=io_i(:),count=io_n(:)) IF (l_o_f) THEN ib(1:4) = ia_sf(1:4); ie(1:4) = ib(1:4)+io_cf(1:4)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i2_4d(ib(1):ie(1),ib(2):ie(2), & & ib(3):ie(3),ib(4):ie(4)), & & start=io_sf(:),count=io_cf(:)) ENDIF IF (l_o_m) THEN ib(1:4) = ia_sm(1:4); ie(1:4) = ib(1:4)+io_cm(1:4)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i2_4d(ib(1):ie(1),ib(2):ie(2), & & ib(3):ie(3),ib(4):ie(4)), & & start=io_sm(:),count=io_cm(:)) ENDIF IF (l_o_l) THEN ib(1:4) = ia_sl(1:4); ie(1:4) = ib(1:4)+io_cl(1:4)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i2_4d(ib(1):ie(1),ib(2):ie(2), & & ib(3):ie(3),ib(4):ie(4)), & & start=io_sl(:),count=io_cl(:)) ENDIF DEALLOCATE(i2_4d) CASE (5) !--- 5d array ALLOCATE(i2_5d(io_n(1),io_n(2),io_n(3),io_n(4),io_n(5))) CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i2_5d, & & start=io_i(:),count=io_n(:)) IF (l_o_f) THEN ib(1:5) = ia_sf(1:5); ie(1:5) = ib(1:5)+io_cf(1:5)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i2_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & & ib(4):ie(4),ib(5):ie(5)), & & start=io_sf(:),count=io_cf(:)) ENDIF IF (l_o_m) THEN ib(1:5) = ia_sm(1:5); ie(1:5) = ib(1:5)+io_cm(1:5)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i2_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & & ib(4):ie(4),ib(5):ie(5)), & & start=io_sm(:),count=io_cm(:)) ENDIF IF (l_o_l) THEN ib(1:5) = ia_sl(1:5); ie(1:5) = ib(1:5)+io_cl(1:5)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i2_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & & ib(4):ie(4),ib(5):ie(5)), & & start=io_sl(:),count=io_cl(:)) ENDIF DEALLOCATE(i2_5d) END SELECT CASE (flio_i4) !--- INTEGER 4 SELECT CASE (v_d_nb(iv)) CASE (0) !--- Scalar CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i4_0d) CALL flioputv (f_id_o,TRIM(f_v_nm(iv)),i4_0d) CASE (1) !--- 1d array ALLOCATE(i4_1d(io_n(1))) CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i4_1d, & & start=io_i(:),count=io_n(:)) IF (l_o_f) THEN ib(1:1) = ia_sf(1:1); ie(1:1) = ib(1:1)+io_cf(1:1)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i4_1d(ib(1):ie(1)), & & start=io_sf(:),count=io_cf(:)) ENDIF IF (l_o_m) THEN ib(1:1) = ia_sm(1:1); ie(1:1) = ib(1:1)+io_cm(1:1)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i4_1d(ib(1):ie(1)), & & start=io_sm(:),count=io_cm(:)) ENDIF IF (l_o_l) THEN ib(1:1) = ia_sl(1:1); ie(1:1) = ib(1:1)+io_cl(1:1)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i4_1d(ib(1):ie(1)), & & start=io_sl(:),count=io_cl(:)) ENDIF DEALLOCATE(i4_1d) CASE (2) !--- 2d array ALLOCATE(i4_2d(io_n(1),io_n(2))) CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i4_2d, & & start=io_i(:),count=io_n(:)) IF (l_o_f) THEN ib(1:2) = ia_sf(1:2); ie(1:2) = ib(1:2)+io_cf(1:2)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i4_2d(ib(1):ie(1),ib(2):ie(2)), & & start=io_sf(:),count=io_cf(:)) ENDIF IF (l_o_m) THEN ib(1:2) = ia_sm(1:2); ie(1:2) = ib(1:2)+io_cm(1:2)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i4_2d(ib(1):ie(1),ib(2):ie(2)), & & start=io_sm(:),count=io_cm(:)) ENDIF IF (l_o_l) THEN ib(1:2) = ia_sl(1:2); ie(1:2) = ib(1:2)+io_cl(1:2)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i4_2d(ib(1):ie(1),ib(2):ie(2)), & & start=io_sl(:),count=io_cl(:)) ENDIF DEALLOCATE(i4_2d) CASE (3) !--- 3d array ALLOCATE(i4_3d(io_n(1),io_n(2),io_n(3))) CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i4_3d, & & start=io_i(:),count=io_n(:)) IF (l_o_f) THEN ib(1:3) = ia_sf(1:3); ie(1:3) = ib(1:3)+io_cf(1:3)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i4_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & & start=io_sf(:),count=io_cf(:)) ENDIF IF (l_o_m) THEN ib(1:3) = ia_sm(1:3); ie(1:3) = ib(1:3)+io_cm(1:3)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i4_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & & start=io_sm(:),count=io_cm(:)) ENDIF IF (l_o_l) THEN ib(1:3) = ia_sl(1:3); ie(1:3) = ib(1:3)+io_cl(1:3)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i4_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & & start=io_sl(:),count=io_cl(:)) ENDIF DEALLOCATE(i4_3d) CASE (4) !--- 4d array ALLOCATE(i4_4d(io_n(1),io_n(2),io_n(3),io_n(4))) CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i4_4d, & & start=io_i(:),count=io_n(:)) IF (l_o_f) THEN ib(1:4) = ia_sf(1:4); ie(1:4) = ib(1:4)+io_cf(1:4)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i4_4d(ib(1):ie(1),ib(2):ie(2), & & ib(3):ie(3),ib(4):ie(4)), & & start=io_sf(:),count=io_cf(:)) ENDIF IF (l_o_m) THEN ib(1:4) = ia_sm(1:4); ie(1:4) = ib(1:4)+io_cm(1:4)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i4_4d(ib(1):ie(1),ib(2):ie(2), & & ib(3):ie(3),ib(4):ie(4)), & & start=io_sm(:),count=io_cm(:)) ENDIF IF (l_o_l) THEN ib(1:4) = ia_sl(1:4); ie(1:4) = ib(1:4)+io_cl(1:4)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i4_4d(ib(1):ie(1),ib(2):ie(2), & & ib(3):ie(3),ib(4):ie(4)), & & start=io_sl(:),count=io_cl(:)) ENDIF DEALLOCATE(i4_4d) CASE (5) !--- 5d array ALLOCATE(i4_5d(io_n(1),io_n(2),io_n(3),io_n(4),io_n(5))) CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i4_5d, & & start=io_i(:),count=io_n(:)) IF (l_o_f) THEN ib(1:5) = ia_sf(1:5); ie(1:5) = ib(1:5)+io_cf(1:5)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i4_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & & ib(4):ie(4),ib(5):ie(5)), & & start=io_sf(:),count=io_cf(:)) ENDIF IF (l_o_m) THEN ib(1:5) = ia_sm(1:5); ie(1:5) = ib(1:5)+io_cm(1:5)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i4_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & & ib(4):ie(4),ib(5):ie(5)), & & start=io_sm(:),count=io_cm(:)) ENDIF IF (l_o_l) THEN ib(1:5) = ia_sl(1:5); ie(1:5) = ib(1:5)+io_cl(1:5)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & i4_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & & ib(4):ie(4),ib(5):ie(5)), & & start=io_sl(:),count=io_cl(:)) ENDIF DEALLOCATE(i4_5d) END SELECT CASE (flio_r4) !--- REAL 4 SELECT CASE (v_d_nb(iv)) CASE (0) !--- Scalar CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r4_0d) CALL flioputv (f_id_o,TRIM(f_v_nm(iv)),r4_0d) CASE (1) !--- 1d array ALLOCATE(r4_1d(io_n(1))) CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r4_1d, & & start=io_i(:),count=io_n(:)) IF (l_o_f) THEN ib(1:1) = ia_sf(1:1); ie(1:1) = ib(1:1)+io_cf(1:1)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r4_1d(ib(1):ie(1)), & & start=io_sf(:),count=io_cf(:)) ENDIF IF (l_o_m) THEN ib(1:1) = ia_sm(1:1); ie(1:1) = ib(1:1)+io_cm(1:1)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r4_1d(ib(1):ie(1)), & & start=io_sm(:),count=io_cm(:)) ENDIF IF (l_o_l) THEN ib(1:1) = ia_sl(1:1); ie(1:1) = ib(1:1)+io_cl(1:1)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r4_1d(ib(1):ie(1)), & & start=io_sl(:),count=io_cl(:)) ENDIF DEALLOCATE(r4_1d) CASE (2) !--- 2d array ALLOCATE(r4_2d(io_n(1),io_n(2))) CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r4_2d, & & start=io_i(:),count=io_n(:)) IF (l_o_f) THEN ib(1:2) = ia_sf(1:2); ie(1:2) = ib(1:2)+io_cf(1:2)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r4_2d(ib(1):ie(1),ib(2):ie(2)), & & start=io_sf(:),count=io_cf(:)) ENDIF IF (l_o_m) THEN ib(1:2) = ia_sm(1:2); ie(1:2) = ib(1:2)+io_cm(1:2)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r4_2d(ib(1):ie(1),ib(2):ie(2)), & & start=io_sm(:),count=io_cm(:)) ENDIF IF (l_o_l) THEN ib(1:2) = ia_sl(1:2); ie(1:2) = ib(1:2)+io_cl(1:2)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r4_2d(ib(1):ie(1),ib(2):ie(2)), & & start=io_sl(:),count=io_cl(:)) ENDIF DEALLOCATE(r4_2d) CASE (3) !--- 3d array ALLOCATE(r4_3d(io_n(1),io_n(2),io_n(3))) CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r4_3d, & & start=io_i(:),count=io_n(:)) IF (l_o_f) THEN ib(1:3) = ia_sf(1:3); ie(1:3) = ib(1:3)+io_cf(1:3)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r4_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & & start=io_sf(:),count=io_cf(:)) ENDIF IF (l_o_m) THEN ib(1:3) = ia_sm(1:3); ie(1:3) = ib(1:3)+io_cm(1:3)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r4_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & & start=io_sm(:),count=io_cm(:)) ENDIF IF (l_o_l) THEN ib(1:3) = ia_sl(1:3); ie(1:3) = ib(1:3)+io_cl(1:3)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r4_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & & start=io_sl(:),count=io_cl(:)) ENDIF DEALLOCATE(r4_3d) CASE (4) !--- 4d array ALLOCATE(r4_4d(io_n(1),io_n(2),io_n(3),io_n(4))) CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r4_4d, & & start=io_i(:),count=io_n(:)) IF (l_o_f) THEN ib(1:4) = ia_sf(1:4); ie(1:4) = ib(1:4)+io_cf(1:4)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r4_4d(ib(1):ie(1),ib(2):ie(2), & & ib(3):ie(3),ib(4):ie(4)), & & start=io_sf(:),count=io_cf(:)) ENDIF IF (l_o_m) THEN ib(1:4) = ia_sm(1:4); ie(1:4) = ib(1:4)+io_cm(1:4)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r4_4d(ib(1):ie(1),ib(2):ie(2), & & ib(3):ie(3),ib(4):ie(4)), & & start=io_sm(:),count=io_cm(:)) ENDIF IF (l_o_l) THEN ib(1:4) = ia_sl(1:4); ie(1:4) = ib(1:4)+io_cl(1:4)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r4_4d(ib(1):ie(1),ib(2):ie(2), & & ib(3):ie(3),ib(4):ie(4)), & & start=io_sl(:),count=io_cl(:)) ENDIF DEALLOCATE(r4_4d) CASE (5) !--- 5d array ALLOCATE(r4_5d(io_n(1),io_n(2),io_n(3),io_n(4),io_n(5))) CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r4_5d, & & start=io_i(:),count=io_n(:)) IF (l_o_f) THEN ib(1:5) = ia_sf(1:5); ie(1:5) = ib(1:5)+io_cf(1:5)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r4_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & & ib(4):ie(4),ib(5):ie(5)), & & start=io_sf(:),count=io_cf(:)) ENDIF IF (l_o_m) THEN ib(1:5) = ia_sm(1:5); ie(1:5) = ib(1:5)+io_cm(1:5)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r4_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & & ib(4):ie(4),ib(5):ie(5)), & & start=io_sm(:),count=io_cm(:)) ENDIF IF (l_o_l) THEN ib(1:5) = ia_sl(1:5); ie(1:5) = ib(1:5)+io_cl(1:5)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r4_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & & ib(4):ie(4),ib(5):ie(5)), & & start=io_sl(:),count=io_cl(:)) ENDIF DEALLOCATE(r4_5d) END SELECT CASE (flio_r8) !--- REAL 8 SELECT CASE (v_d_nb(iv)) CASE (0) !--- Scalar CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r8_0d) CALL flioputv (f_id_o,TRIM(f_v_nm(iv)),r8_0d) CASE (1) !--- 1d array ALLOCATE(r8_1d(io_n(1))) CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r8_1d, & & start=io_i(:),count=io_n(:)) IF (l_o_f) THEN ib(1:1) = ia_sf(1:1); ie(1:1) = ib(1:1)+io_cf(1:1)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r8_1d(ib(1):ie(1)), & & start=io_sf(:),count=io_cf(:)) ENDIF IF (l_o_m) THEN ib(1:1) = ia_sm(1:1); ie(1:1) = ib(1:1)+io_cm(1:1)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r8_1d(ib(1):ie(1)), & & start=io_sm(:),count=io_cm(:)) ENDIF IF (l_o_l) THEN ib(1:1) = ia_sl(1:1); ie(1:1) = ib(1:1)+io_cl(1:1)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r8_1d(ib(1):ie(1)), & & start=io_sl(:),count=io_cl(:)) ENDIF DEALLOCATE(r8_1d) CASE (2) !--- 2d array ALLOCATE(r8_2d(io_n(1),io_n(2))) CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r8_2d, & & start=io_i(:),count=io_n(:)) IF (l_o_f) THEN ib(1:2) = ia_sf(1:2); ie(1:2) = ib(1:2)+io_cf(1:2)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r8_2d(ib(1):ie(1),ib(2):ie(2)), & & start=io_sf(:),count=io_cf(:)) ENDIF IF (l_o_m) THEN ib(1:2) = ia_sm(1:2); ie(1:2) = ib(1:2)+io_cm(1:2)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r8_2d(ib(1):ie(1),ib(2):ie(2)), & & start=io_sm(:),count=io_cm(:)) ENDIF IF (l_o_l) THEN ib(1:2) = ia_sl(1:2); ie(1:2) = ib(1:2)+io_cl(1:2)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r8_2d(ib(1):ie(1),ib(2):ie(2)), & & start=io_sl(:),count=io_cl(:)) ENDIF DEALLOCATE(r8_2d) CASE (3) !--- 3d array ALLOCATE(r8_3d(io_n(1),io_n(2),io_n(3))) CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r8_3d, & & start=io_i(:),count=io_n(:)) IF (l_o_f) THEN ib(1:3) = ia_sf(1:3); ie(1:3) = ib(1:3)+io_cf(1:3)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r8_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & & start=io_sf(:),count=io_cf(:)) ENDIF IF (l_o_m) THEN ib(1:3) = ia_sm(1:3); ie(1:3) = ib(1:3)+io_cm(1:3)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r8_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & & start=io_sm(:),count=io_cm(:)) ENDIF IF (l_o_l) THEN ib(1:3) = ia_sl(1:3); ie(1:3) = ib(1:3)+io_cl(1:3)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r8_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & & start=io_sl(:),count=io_cl(:)) ENDIF DEALLOCATE(r8_3d) CASE (4) !--- 4d array ALLOCATE(r8_4d(io_n(1),io_n(2),io_n(3),io_n(4))) CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r8_4d, & & start=io_i(:),count=io_n(:)) IF (l_o_f) THEN ib(1:4) = ia_sf(1:4); ie(1:4) = ib(1:4)+io_cf(1:4)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r8_4d(ib(1):ie(1),ib(2):ie(2), & & ib(3):ie(3),ib(4):ie(4)), & & start=io_sf(:),count=io_cf(:)) ENDIF IF (l_o_m) THEN ib(1:4) = ia_sm(1:4); ie(1:4) = ib(1:4)+io_cm(1:4)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r8_4d(ib(1):ie(1),ib(2):ie(2), & & ib(3):ie(3),ib(4):ie(4)), & & start=io_sm(:),count=io_cm(:)) ENDIF IF (l_o_l) THEN ib(1:4) = ia_sl(1:4); ie(1:4) = ib(1:4)+io_cl(1:4)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r8_4d(ib(1):ie(1),ib(2):ie(2), & & ib(3):ie(3),ib(4):ie(4)), & & start=io_sl(:),count=io_cl(:)) ENDIF DEALLOCATE(r8_4d) CASE (5) !--- 5d array ALLOCATE(r8_5d(io_n(1),io_n(2),io_n(3),io_n(4),io_n(5))) CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r8_5d, & & start=io_i(:),count=io_n(:)) IF (l_o_f) THEN ib(1:5) = ia_sf(1:5); ie(1:5) = ib(1:5)+io_cf(1:5)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r8_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & & ib(4):ie(4),ib(5):ie(5)), & & start=io_sf(:),count=io_cf(:)) ENDIF IF (l_o_m) THEN ib(1:5) = ia_sm(1:5); ie(1:5) = ib(1:5)+io_cm(1:5)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r8_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & & ib(4):ie(4),ib(5):ie(5)), & & start=io_sm(:),count=io_cm(:)) ENDIF IF (l_o_l) THEN ib(1:5) = ia_sl(1:5); ie(1:5) = ib(1:5)+io_cl(1:5)-1; CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & & r8_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & & ib(4):ie(4),ib(5):ie(5)), & & start=io_sl(:),count=io_cl(:)) ENDIF DEALLOCATE(r8_5d) END SELECT END SELECT !-------- eventually close each file containing a small piece of data CALL flrb_cf (i_i,l_ocf.AND.l_cgd.AND.(i_i /= 1)) ENDDO !------ If needed, deallocate io_* arrays IF (v_d_nb(iv) > 0) THEN DEALLOCATE(io_i,io_n,ia_sm,io_sm,io_cm) IF (TRIM(c_d_n) == "apple") THEN DEALLOCATE(ia_sf,io_sf,io_cf) DEALLOCATE(ia_sl,io_sl,io_cl) ENDIF ENDIF ENDDO ENDDO ENDDO !- !------------------- ! Ending the work !------------------- !- ! Close files CALL flrb_cf (0,.TRUE.) !- ! Deallocate DEALLOCATE(f_nm,f_a_id) DEALLOCATE(f_d_nm,f_v_nm,f_a_nm) DEALLOCATE(f_d_i,f_d_l) DEALLOCATE(v_d_nb,v_d_ul,v_type,v_d_i) DEALLOCATE(d_d_i,d_s_g) DEALLOCATE(d_s_l,d_p_f,d_p_l,d_h_s,d_h_e) !- IF (i_v_lev >= 1) THEN !-- elapsed and cpu time computation CALL cpu_time (t_cpu_end) CALL system_clock(count=nb_cc_end) WRITE (UNIT=*,FMT='("")') WRITE (UNIT=*,fmt='(" elapsed time (s) : ",1PE11.4)') & & REAL(nb_cc_end-nb_cc_ini)/REAL(nb_cc_sec) WRITE (UNIT=*,fmt='(" CPU time (s) : ",1PE11.4)') & & t_cpu_end-t_cpu_ini ENDIF !======= CONTAINS !======= SUBROUTINE flrb_of (i_f_n,i_f_i) !--------------------------------------------------------------------- ! Open the file of number "i_f_n" if necessary, ! and returns its identifier in "i_f_i". !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: i_f_n INTEGER,INTENT(OUT) :: i_f_i !--------------------------------------------------------------------- IF (f_a_id(i_f_n) < 0) THEN CALL flioopfd (TRIM(f_nm(i_f_n)),i_f_i) f_a_id(i_f_n) = i_f_i ELSE i_f_i = f_a_id(i_f_n) ENDIF !--------------------- END SUBROUTINE flrb_of !=== SUBROUTINE flrb_cf (i_f_n,l_cf) !--------------------------------------------------------------------- ! Close the file of number "i_f_n" if "l_cf" is TRUE. ! Close all files if "i_f_n <= 0". !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: i_f_n LOGICAL,INTENT(IN) :: l_cf !--------------------------------------------------------------------- IF (i_f_n <= 0) THEN CALL flioclo () f_a_id(:) = -1 ELSE IF (l_cf) THEN IF (f_a_id(i_f_n) < 0) THEN CALL ipslerr (2,"flio_rbld", & & "The file",TRIM(f_nm(i_f_n)),"is already closed") ELSE CALL flioclo (f_a_id(i_f_n)) f_a_id(i_f_n) = -1 ENDIF ENDIF ENDIF !--------------------- END SUBROUTINE flrb_cf !=== SUBROUTINE flrb_rg !--------------------------------------------------------------------- ! Update valid_min valid_max attributes values !--------------------------------------------------------------------- INTEGER :: k,j LOGICAL :: l_vmin,l_vmax INTEGER(KIND=i_4) :: i4_vmin,i4_vmax REAL(KIND=r_4) :: r4_vmin,r4_vmax REAL(KIND=r_8) :: r8_vmin,r8_vmax !--------------------------------------------------------------------- DO k=1,f_v_nb !-- get attribute informations CALL flioinqa & & (f_id_i1,TRIM(f_v_nm(k)),'valid_min',l_vmin,a_t=a_type) CALL flioinqa & & (f_id_i1,TRIM(f_v_nm(k)),'valid_max',l_vmax,a_t=a_type) !--- IF (l_vmin.OR.l_vmax) THEN !---- get values of min/max SELECT CASE (a_type) CASE (flio_i1,flio_i2,flio_i4) !--- INTEGER 1/2/4 DO j=1,f_nb_in CALL flrb_of (j,f_id_i) IF (l_vmin) THEN CALL fliogeta(f_id_i,TRIM(f_v_nm(k)),"valid_min",i4_0d) IF (j == 1) THEN i4_vmin = i4_0d ELSE i4_vmin = MIN(i4_vmin,i4_0d) ENDIF ENDIF IF (l_vmax) THEN CALL fliogeta(f_id_i,TRIM(f_v_nm(k)),"valid_max",i4_0d) IF (j == 1) THEN i4_vmax = i4_0d ELSE i4_vmax = MAX(i4_vmax,i4_0d) ENDIF ENDIF CALL flrb_cf (j,l_ocf.AND.(f_id_i /= f_id_i1)) ENDDO IF (l_vmin) THEN CALL flioputa (f_id_o,TRIM(f_v_nm(k)),"valid_min",i4_vmin) ENDIF IF (l_vmax) THEN CALL flioputa (f_id_o,TRIM(f_v_nm(k)),"valid_max",i4_vmax) ENDIF CASE (flio_r4) !--- REAL 4 DO j=1,f_nb_in CALL flrb_of (j,f_id_i) IF (l_vmin) THEN CALL fliogeta(f_id_i,TRIM(f_v_nm(k)),"valid_min",r4_0d) IF (j == 1) THEN r4_vmin = r4_0d ELSE r4_vmin = MIN(r4_vmin,r4_0d) ENDIF ENDIF IF (l_vmax) THEN CALL fliogeta(f_id_i,TRIM(f_v_nm(k)),"valid_max",r4_0d) IF (j == 1) THEN r4_vmax = r4_0d ELSE r4_vmax = MAX(r4_vmax,r4_0d) ENDIF ENDIF CALL flrb_cf (j,l_ocf.AND.(f_id_i /= f_id_i1)) ENDDO IF (l_vmin) THEN CALL flioputa (f_id_o,TRIM(f_v_nm(k)),"valid_min",r4_vmin) ENDIF IF (l_vmax) THEN CALL flioputa (f_id_o,TRIM(f_v_nm(k)),"valid_max",r4_vmax) ENDIF CASE (flio_r8) !--- REAL 8 DO j=1,f_nb_in CALL flrb_of (j,f_id_i) IF (l_vmin) THEN CALL fliogeta(f_id_i,TRIM(f_v_nm(k)),"valid_min",r8_0d) IF (j == 1) THEN r8_vmin = r8_0d ELSE r8_vmin = MIN(r8_vmin,r8_0d) ENDIF ENDIF IF (l_vmax) THEN CALL fliogeta(f_id_i,TRIM(f_v_nm(k)),"valid_max",r8_0d) IF (j == 1) THEN r8_vmax = r8_0d ELSE r8_vmax = MAX(r8_vmax,r8_0d) ENDIF ENDIF CALL flrb_cf (j,l_ocf.AND.(f_id_i /= f_id_i1)) ENDDO IF (l_vmin) THEN CALL flioputa (f_id_o,TRIM(f_v_nm(k)),"valid_min",r8_vmin) ENDIF IF (l_vmax) THEN CALL flioputa (f_id_o,TRIM(f_v_nm(k)),"valid_max",r8_vmax) ENDIF END SELECT ENDIF ENDDO !--------------------- END SUBROUTINE flrb_rg !=== SUBROUTINE ZeroFill(f_id_o,f_v_nm,f_d_l,v_d_nb,v_type,v_d_i) IMPLICIT NONE ! Character length INTEGER,PARAMETER :: chlen=256 INTEGER :: v_d_nb, v_type ! variable # of dims, variable type, var Unlim dimension INTEGER :: f_id_o ! Output file ID INTEGER,DIMENSION(:) :: f_d_l, v_d_i ! Global dimensions, variable dimensio ID CHARACTER(LEN=chlen) :: f_v_nm ! Variable name INTEGER,DIMENSION(:),ALLOCATABLE :: dims INTEGER(KIND=i_2) :: i2_0d INTEGER(KIND=i_2), ALLOCATABLE :: i2_1d(:), i2_2d(:,:), i2_3d(:,:,:), i2_4d(:,:,:,:), i2_5d(:,:,:,:,:) INTEGER(KIND=i_4) :: i4_0d INTEGER(KIND=i_4), ALLOCATABLE :: i4_1d(:), i4_2d(:,:), i4_3d(:,:,:), i4_4d(:,:,:,:), i4_5d(:,:,:,:,:) REAL(KIND=r_4) :: r4_0d REAL(KIND=r_4), ALLOCATABLE :: r4_1d(:), r4_2d(:,:), r4_3d(:,:,:), r4_4d(:,:,:,:), r4_5d(:,:,:,:,:) REAL(KIND=r_8) :: r8_0d REAL(KIND=r_8), ALLOCATABLE :: r8_1d(:), r8_2d(:,:), r8_3d(:,:,:), r8_4d(:,:,:,:), r8_5d(:,:,:,:,:) ! write(*,*) ' Into my sub... TOM' ! write(*,*) f_id_o, TRIM(f_v_nm), v_d_nb , v_type write(*,*) 'Variable: ',TRIM(f_v_nm), ' intiliazed to zero' write(*,*) ! define variable dimension ALLOCATE(dims(v_d_nb)) dims=f_d_l(v_d_i) SELECT CASE(v_type) ! INTEGER 1 and 2 CASE (flio_i1,flio_i2) SELECT CASE (v_d_nb) CASE(1) ALLOCATE(i2_1d(dims(1))) i2_1d=0 CALL flioputv (f_id_o,TRIM(f_v_nm),i2_1d) DEALLOCATE(i2_1d) CASE(2) ALLOCATE(i2_2d(dims(1),dims(2))) i2_2d=0 CALL flioputv (f_id_o,TRIM(f_v_nm),i2_2d) DEALLOCATE(i2_2d) CASE(3) ALLOCATE(i2_3d(dims(1),dims(2),dims(3))) i2_3d=0 CALL flioputv (f_id_o,TRIM(f_v_nm),i2_3d) DEALLOCATE(i2_3d) CASE(4) ALLOCATE(i2_4d(dims(1),dims(2),dims(3),dims(4))) i2_4d=0 CALL flioputv (f_id_o,TRIM(f_v_nm),i2_4d) DEALLOCATE(i2_4d) CASE(5) ALLOCATE(i2_5d(dims(1),dims(2),dims(3),dims(4),dims(5))) i2_5d=0 CALL flioputv (f_id_o,TRIM(f_v_nm),i2_5d) DEALLOCATE(i2_5d) END SELECT ! INTEGER 4 CASE (flio_i4) SELECT CASE (v_d_nb) CASE(1) ALLOCATE(i4_1d(dims(1))) i4_1d=0 CALL flioputv (f_id_o,TRIM(f_v_nm),i4_1d) DEALLOCATE(i4_1d) CASE(2) ALLOCATE(i4_2d(dims(1),dims(2))) i4_2d=0 CALL flioputv (f_id_o,TRIM(f_v_nm),i4_2d) DEALLOCATE(i4_2d) CASE(3) ALLOCATE(i4_3d(dims(1),dims(2),dims(3))) i4_3d=0 CALL flioputv (f_id_o,TRIM(f_v_nm),i4_3d) DEALLOCATE(i4_3d) CASE(4) ALLOCATE(i4_4d(dims(1),dims(2),dims(3),dims(4))) i4_4d=0 CALL flioputv (f_id_o,TRIM(f_v_nm),i4_4d) DEALLOCATE(i4_4d) CASE(5) ALLOCATE(i4_5d(dims(1),dims(2),dims(3),dims(4),dims(5))) i4_5d=0 CALL flioputv (f_id_o,TRIM(f_v_nm),i4_5d) DEALLOCATE(i4_5d) END SELECT ! FLOAT 4 CASE (flio_r4) SELECT CASE (v_d_nb) CASE(1) ALLOCATE(r4_1d(dims(1))) r4_1d=0 CALL flioputv (f_id_o,TRIM(f_v_nm),r4_1d) DEALLOCATE(r4_1d) CASE(2) ALLOCATE(r4_2d(dims(1),dims(2))) r4_2d=0 CALL flioputv (f_id_o,TRIM(f_v_nm),r4_2d) DEALLOCATE(r4_2d) CASE(3) ALLOCATE(r4_3d(dims(1),dims(2),dims(3))) r4_3d=0 CALL flioputv (f_id_o,TRIM(f_v_nm),r4_3d) DEALLOCATE(r4_3d) CASE(4) ALLOCATE(r4_4d(dims(1),dims(2),dims(3),dims(4))) r4_4d=0 CALL flioputv (f_id_o,TRIM(f_v_nm),r4_4d) DEALLOCATE(r4_4d) CASE(5) ALLOCATE(r4_5d(dims(1),dims(2),dims(3),dims(4),dims(5))) r4_5d=0 CALL flioputv (f_id_o,TRIM(f_v_nm),r4_5d) DEALLOCATE(r4_5d) END SELECT ! FLOAT 8 CASE (flio_r8) SELECT CASE (v_d_nb) CASE(1) ALLOCATE(r8_1d(dims(1))) r8_1d=0 CALL flioputv (f_id_o,TRIM(f_v_nm),r8_1d) DEALLOCATE(r8_1d) CASE(2) ALLOCATE(r8_2d(dims(1),dims(2))) r8_2d=0 CALL flioputv (f_id_o,TRIM(f_v_nm),r8_2d) DEALLOCATE(r8_2d) CASE(3) ALLOCATE(r8_3d(dims(1),dims(2),dims(3))) r8_3d=0 CALL flioputv (f_id_o,TRIM(f_v_nm),r8_3d) DEALLOCATE(r8_3d) CASE(4) ALLOCATE(r8_4d(dims(1),dims(2),dims(3),dims(4))) r8_4d=0 CALL flioputv (f_id_o,TRIM(f_v_nm),r8_4d) DEALLOCATE(r8_4d) CASE(5) ALLOCATE(r8_5d(dims(1),dims(2),dims(3),dims(4),dims(5))) r8_5d=0 CALL flioputv (f_id_o,TRIM(f_v_nm),r8_5d) DEALLOCATE(r8_5d) END SELECT END SELECT DEALLOCATE (dims) END SUBROUTINE !=== !-------------------- END PROGRAM flio_rbld