psmile_def_metadata.F90

Go to the documentation of this file.
00001 !-----------------------------------------------------------------------
00002 ! Copyright 2006-2010, SGI Germany, Munich, Germany.
00003 ! All rights reserved. Use is subject to OASIS4 license terms.
00004 !-----------------------------------------------------------------------
00005 !BOP
00006 ! !ROUTINE: PSMILE_Def_Metadata
00007 ! !INTERFACE:
00008       subroutine psmile_def_metadata (id_varid, ierror )
00009 
00010 ! !USES:
00011       use PSMILe, dummy_interface => PSMILE_Def_Metadata
00012       use psmile_io_get
00013 
00014       implicit none
00015       include 'prism.inc' 
00016 ! !OUTPUT PARAMETERS:
00017       integer, Intent (Out)               :: ierror
00018 ! !INPUT PARAMETERS:
00019       integer, Intent (In)                :: id_varid
00020 
00021 !
00022 ! !LOCAL VARIABLES
00023 !
00024       integer                             :: ierrp(2)
00025       integer                 :: il_action,tskid,ichan
00026       integer                             :: il_max_no,i
00027       double precision                    :: dl_max,dl_min
00028       Type(IO_Data),Pointer       :: pl_io_info
00029 !
00030 ! !DESCRIPTION:
00031 !  
00032 ! 1st) Allocates the substructure io_infos Fields(varid) 
00033 !      which carries the essential informations
00034 !      to open a file and to write a NetCDF CF file header.
00035 ! 2nd) Initializes the substructure with the metadata informations
00036 !
00037 ! !REVISION HISTORY:
00038 ! 
00039 !   Date      Programmer    Description
00040 ! ----------  -----------   -----------
00041 ! 03.04.2003  declat        created
00042 ! 31.10.2003  vogelsang     Allocation of substructure io_infos and
00043 !                           initialization
00044 ! 04.03.01  R.Vogelsang     Added code to extract labels of bundles
00045 ! 04.05.24  R.Vogelsang     Allocation of vcmp_names and labels is now done
00046 !                           in psmile_io_get_info_init. Nullify of those
00047 !                           character pointers removed.
00048 ! ---------------------------------------------------------------------
00049 !EOP
00050 !
00051       Character(len=len_cvs_string),save :: def_meta_cvs= 
00052 '$Id: psmile_def_metadata.F90 2923 2011-01-27 15:43:13Z coquart $'
00053 
00054       ierror = 0
00055 #ifdef __PSMILE_WITH_IO
00056 #ifdef VERBOSE
00057       print*,trim(ch_id),' : psmile_def_metadata: start'
00058       call psmile_flushstd
00059 #endif
00060 
00061 !
00062 ! Argument checking
00063 !
00064 
00065       if (.not.associated(Fields)) then
00066 
00067          ierror = PRISM_Error_Internal
00068          call psmile_error ( ierror, 'Fields not allocated ', &
00069                              ierrp, 0, __FILE__, __LINE__ )
00070       endif
00071      
00072       if ( (id_varid .gt. Size(Fields)).or.(id_varid.lt.1) .or. &
00073            (Fields(id_varid)%status .eq. PSMILe_Status_undefined) ) then
00074 
00075          ierror = PRISM_Error_Internal
00076          call psmile_error ( ierror, 'Fields(varid) status undefined ', &
00077                              ierrp, 0, __FILE__, __LINE__ )
00078       endif
00079 
00080       call psmile_io_get_info_init(id_varid,ierror)
00081 
00082 #ifdef DEBUG
00083       print*,trim(ch_id),' : psmile_def_metadata: ' &
00084                        ,'associated(Fields(id_varid)%io_chan_infos)?' &
00085                        ,associated(Fields(id_varid)%io_chan_infos)
00086       call psmile_flushstd
00087 #endif
00088 !
00089 ! Short cut: I try to perform an inquiry of the action to be performed.
00090 !            If the action returned is PSMILe_Status_undefined no further
00091 !            action on file I/O is taken.
00092 
00093       if(.not.associated(Fields(id_varid)%io_chan_infos)) then
00094 #ifdef VERBOSE
00095          print*,trim(ch_id),' : psmile_def_metadata: end'
00096          call psmile_flushstd
00097 #endif
00098          return
00099       endif
00100 
00101 !
00102 !   Loop over tasks. If task is file I/O related associate io_chan_infos
00103 !   with SMIOC related informations.
00104 !
00105     do tskid=1,size(Fields(id_varid)%io_task_lookup) ! Loop over tasks
00106 
00107       ichan=Fields(id_varid)%io_task_lookup(tskid)
00108 #ifdef DEBUG
00109       print*,trim(ch_id),' : psmile_def_metadata: tskid=',tskid,ichan
00110       call psmile_flushstd
00111 #endif
00112       if(ichan.lt.0) cycle
00113 !
00114 ! Association of the Field's substructure io_infos
00115 !
00116       
00117       Fields(id_varid)%io_infos =>  Fields(id_varid)%io_chan_infos(ichan)
00118 
00119 !
00120 !    Main section of the initialization of I/O channel informations
00121 !      
00122       pl_io_info => Fields(id_varid)%io_infos
00123 
00124       Nullify(pl_io_info%p_cf_names)
00125       Nullify(pl_io_info%p_cf_maps)
00126       Nullify(pl_io_info%p_cache)
00127       Nullify(pl_io_info%related_ids)
00128       Nullify(pl_io_info%fp_dble)
00129       Nullify(pl_io_info%fp_real)
00130       Nullify(pl_io_info%fp_int)
00131  
00132       pl_io_info%status=PSMILe_status_undefined
00133       pl_io_info%old_filesize=0
00134       pl_io_info%current_filesize=0
00135       pl_io_info%opened=.FALSE.
00136       pl_io_info%action=PSMILe_undef
00137       pl_io_info%filename=''
00138       pl_io_info%cfioname=''
00139       pl_io_info%isuffix=PSMILe_undef
00140       pl_io_info%file_unit=PSMILe_undef
00141       pl_io_info%format=PSMILe_undef
00142       pl_io_info%fileset=PSMILe_undef
00143       pl_io_info%threading=PSMILe_undef
00144       pl_io_info%long_name=''
00145       pl_io_info%standard_name=''
00146       pl_io_info%vcmp_names=''
00147       pl_io_info%labels=''
00148       pl_io_info%units=''
00149       pl_io_info%height_formular=''
00150       pl_io_info%height_stdname=''
00151       pl_io_info%height_unit=''
00152       pl_io_info%positive=''
00153       pl_io_info%pack_mode=PSMILe_undef
00154       pl_io_info%type_spec=PSMILe_undef
00155       pl_io_info%scale=PSMILe_undef
00156       pl_io_info%add=PSMILe_undef
00157       pl_io_info%valid_min=PSMILe_undef
00158       pl_io_info%valid_max=PSMILe_undef
00159       pl_io_info%fill_value=def_init_val
00160       pl_io_info%missing_value=def_init_val
00161       pl_io_info%ilag_mode=PSMILe_undef
00162       pl_io_info%weight=PSMILe_undef
00163       pl_io_info%sense=PSMILe_undef
00164       
00165 
00166       call psmile_io_get_info(id_varid,tskid,PSMILe_IO_GET_ACTION &
00167                              , pl_io_info%action,ierror)
00168       call psmile_io_get_info(id_varid,tskid,PSMILe_IO_GET_FILENAME &
00169                              ,pl_io_info%filename,ierror)
00170       call psmile_io_get_info(id_varid,tskid,PSMILe_IO_GET_CFIONAME &
00171                              ,pl_io_info%cfioname,ierror)
00172       call psmile_io_get_info(id_varid,tskid,PSMILe_IO_GET_SUFFIX &
00173                              ,pl_io_info%isuffix,ierror)
00174       call psmile_io_get_info(id_varid,tskid,PSMILe_IO_GET_FILEUNIT &
00175                              ,pl_io_info%file_unit,ierror)
00176       call psmile_io_get_info(id_varid,tskid,PSMILe_IO_GET_FORMAT &
00177                              ,pl_io_info%format,ierror)
00178       call psmile_io_get_info(id_varid,tskid,PSMILe_IO_GET_FILESET &
00179                              ,pl_io_info%fileset,ierror)
00180       call psmile_io_get_info(id_varid,tskid,PSMILe_IO_GET_THREADING &
00181                              ,pl_io_info%threading,ierror)
00182       call psmile_io_get_info(id_varid,tskid,PSMILe_IO_GET_CFLNGNAME &
00183                              ,pl_io_info%long_name,ierror)
00184       call psmile_io_get_info(id_varid,tskid,PSMILe_IO_GET_CFSHRTNAME &
00185                              ,pl_io_info%standard_name,ierror)
00186       call psmile_io_get_info(id_varid,tskid,PSMILe_IO_GET_VCMPNAMES &
00187                              ,pl_io_info%vcmp_names,ierror)
00188       call psmile_io_get_info(id_varid,tskid,PSMILe_IO_GET_BNDLNAMES &
00189                              ,pl_io_info%labels,ierror)
00190       call psmile_io_get_info(id_varid,tskid,PSMILe_IO_GET_CFUNITS &
00191                              ,pl_io_info%units,ierror)
00192       call psmile_io_get_info(id_varid,tskid,PSMILe_IO_GET_PACK &
00193                              ,pl_io_info%pack_mode,ierror)
00194       call psmile_io_get_info(id_varid,tskid,PSMILe_IO_GET_TYPE_SPEC &
00195                              ,pl_io_info%type_spec,ierror)
00196       call psmile_io_get_info(id_varid,tskid,PSMILe_IO_GET_SCALE &
00197                              ,pl_io_info%scale,ierror)
00198       call psmile_io_get_info(id_varid,tskid,PSMILe_IO_GET_ADD &
00199                              ,pl_io_info%add,ierror)
00200       call psmile_io_get_info(id_varid,tskid,PSMILe_IO_GET_VALID_MIN &
00201                              ,pl_io_info%valid_min,ierror)
00202       call psmile_io_get_info(id_varid,tskid,PSMILe_IO_GET_VALID_MAX &
00203                              ,pl_io_info%valid_max,ierror)
00204       call psmile_io_get_info(id_varid,tskid,PSMILe_IO_GET_FILL &
00205                              ,pl_io_info%fill_value,ierror)
00206       call psmile_io_get_info(id_varid,tskid,PSMILe_IO_GET_LAGMODE &
00207                              ,pl_io_info%ilag_mode,ierror)
00208       call psmile_io_get_info(id_varid,tskid,PSMILe_IO_GET_LAGWEIGHT &
00209                              ,pl_io_info%weight,ierror)
00210       pl_io_info%status=PSMILe_status_defined
00211 
00212       
00213 #ifdef DEBUG
00214       print*, trim(ch_id), ' : psmile_def_metadata: IO_Data task= ',tskid,'<'
00215       print*,trim(ch_id),' : psmile_def_metadata: Fields(id_varid)%local_name ' &
00216                         ,trim(Fields(id_varid)%local_name) 
00217       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%cfioname ' &
00218                         ,trim(pl_io_info%cfioname)
00219       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%filename ' ,trim(pl_io_info%filename)
00220       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%isuffix ' ,pl_io_info%isuffix
00221       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%file_unit ',pl_io_info%file_unit
00222       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%action ',pl_io_info%action 
00223       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%format ',pl_io_info%format 
00224       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%threading ',pl_io_info%threading 
00225       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%fileset ',pl_io_info%fileset 
00226       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%status ',pl_io_info%status 
00227       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%old_filesize ',pl_io_info%old_filesize 
00228       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%current_filesize ' &
00229                         ,pl_io_info%current_filesize 
00230       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%standard_name ' &
00231                         ,trim(pl_io_info%standard_name) 
00232       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%long_name ',trim(pl_io_info%long_name) 
00233       do i=1,size(pl_io_info%vcmp_names)
00234         print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%vcmp_names ' &
00235                           ,trim(pl_io_info%vcmp_names(i)) 
00236       enddo
00237       do i=1,size(pl_io_info%labels)
00238         print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%labels ' &
00239                           ,trim(pl_io_info%labels(i)) 
00240       enddo
00241       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%units ',trim(pl_io_info%units) 
00242       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%height_stdname ' &
00243                         ,trim(pl_io_info%height_stdname) 
00244       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%height_unit ' &
00245                         ,trim(pl_io_info%height_unit) 
00246       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%height_formular ' &
00247                         ,trim(pl_io_info%height_formular) 
00248       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%positive ',trim(pl_io_info%positive) 
00249       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%sense ',pl_io_info%sense 
00250       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%pack_mode ' ,pl_io_info%pack_mode
00251       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%type_spec ',pl_io_info%type_spec 
00252       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%scale ',pl_io_info%scale 
00253       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%add ',pl_io_info%add 
00254       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%valid_min ' ,pl_io_info%valid_min
00255       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%valid_max ' ,pl_io_info%valid_max
00256       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%fill_value ' ,pl_io_info%fill_value
00257       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%missing_value ' &
00258                         ,pl_io_info%missing_value 
00259       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%ilag_mode ',pl_io_info%ilag_mode 
00260       print*,trim(ch_id),' : psmile_def_metadata: pl_io_info%weight ',pl_io_info%weight 
00261       PRINT*,TRIM(ch_id),' : psmile_def_metadata: pl_io_info%opened ',pl_io_info%opened
00262 
00263       print*, trim(ch_id), ' : psmile_def_metadata: IO_Data >'
00264 #endif
00265 !
00266 !     Coherence check of the scale/add factors for higher pack modes
00267 !     The valid min or /valid max (whatever absolute value is larger)
00268 !     should fit into a 1 byte integer (pack_mode=8) or a 2 byte integer
00269 !     (pach_mode=4) after applying scale*value+add
00270 !
00271       if(pl_io_info%pack_mode.ge.4) then
00272 
00273         dl_max=pl_io_info%valid_max
00274         dl_min=pl_io_info%valid_min
00275         dl_max=max(abs(dl_max),abs(dl_min))
00276 
00277         Select Case ( pl_io_info%pack_mode)
00278         Case(psmile_four)
00279           il_max_no=2**15-1
00280         Case(psmile_eight)
00281           il_max_no=2**7-1
00282         End Select
00283 
00284         if(abs(pl_io_info%scale).lt.1.d-36) then
00285            ierror=PRISM_Error_IO_Meta
00286            call psmile_error ( ierror &
00287           ,'Scale factor close to zero! ' &
00288            ,ierrp, 0, __FILE__, __LINE__ )
00289         endif
00290 
00291         if(abs((pl_io_info%fill_value-pl_io_info%add)/pl_io_info%scale) &
00292            .gt.dble(il_max_no)) then
00293 
00294           pl_io_info%fill_value=pl_io_info%scale*il_max_no+pl_io_info%add
00295           print*,trim(ch_id),' : Warning : Fill value reset to ' &
00296                 ,pl_io_info%fill_value
00297           call psmile_flushstd
00298 
00299         endif
00300 
00301         if(abs((pl_io_info%missing_value-pl_io_info%add)/pl_io_info%scale) &
00302            .gt.dble(il_max_no)) then
00303 
00304           pl_io_info%missing_value=pl_io_info%scale*il_max_no+pl_io_info%add
00305           print*,trim(ch_id),' : Warning : Missing value reset to ' &
00306                 ,pl_io_info%missing_value
00307           call psmile_flushstd
00308 
00309         endif
00310 
00311         dl_max=abs((dl_max-pl_io_info%add)/pl_io_info%scale)
00312         if(int(dl_max).gt.il_max_no) then
00313            ierror=PRISM_Error_IO_Meta
00314            call psmile_error ( ierror &
00315           ,'abs(valid_[min,max]-add)/scale > 2**(64/pack_mode) ! ' &
00316            ,ierrp, 0, __FILE__, __LINE__ )
00317         endif
00318       endif
00319 !
00320     enddo   ! End of loop over tasks
00321 !
00322 #ifdef VERBOSE
00323       print*,trim(ch_id),' : psmile_def_metadata: end'
00324       call psmile_flushstd
00325       
00326 #endif      
00327 #endif
00328 
00329       end subroutine PSMILe_Def_Metadata