psmile_io_get.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 !
00007 ! !MODULE:  psmile_io_get
00008 module psmile_io_get
00009 ! !USES:
00010 !
00011 ! !INTERFACE:
00012 
00013         interface psmile_io_get_info
00014           module procedure psmile_io_get_info_init
00015           module procedure psmile_io_get_info_i4
00016           module procedure psmile_io_get_info_i41
00017           module procedure psmile_io_get_info_r8
00018           module procedure psmile_io_get_info_r81
00019           module procedure psmile_io_get_info_ch
00020           module procedure psmile_io_get_info_ch1
00021         end interface
00022 
00023 !
00024 ! !DESCRIPTION:
00025 ! The generic interface  psmile_io_get_info accepts a PSMILe varid, tskid and a
00026 ! inquire action identified by inqid in order to get a SMIOC/SCC related
00027 ! information to be returned by the last argument which can be an integer,
00028 ! array of integers, a double precision, an array of double precision,
00029 ! a character string or an array of character strings.
00030 ! psmile_io_get_info_init initializes the indices into the array of
00031 ! structs containing the SMIOC related informations.
00032 !
00033 ! !REVISION HISTORY:
00034 !   Date      Programmer    Description
00035 ! ----------  -----------   -----------
00036 ! 03.05.07  R.Vogelsang     created
00037 ! 04.02.16  R.Vogelsang     Usage of SMIOC related infos
00038 ! 04.03.01  R.Vogelsang     Added code to extract labels of bundles
00039 ! 04.04.27  R.Vogelsang     Nullify of pointer substructures
00040 ! 04.05.24  R.Vogelsang     Allocation of vcmp_names and labels is now done
00041 !                           in psmile_io_get_info_init
00042 !
00043 ! EOP
00044 !-----------------------------------------------------------------------
00045 !$Id: psmile_io_get.F90 2923 2011-01-27 15:43:13Z coquart $
00046         integer,save:: il_smioc_index,il_smioc_loc,il_in_loc,il_out_loc
00047         integer,save::ig_transiouts
00048         logical,save::lread,lwrite,llag
00049 contains
00050          subroutine psmile_io_get_info_init(id_varid,ierror)
00051 !-----------------------------------------------------------------------
00052          use psmile
00053          use PSMILe_SMIOC, only : sga_smioc_transi,sga_smioc_grids &
00054                                 , iga_comp_nb_grids
00055          implicit none
00056          include 'prism.inc'
00057 !
00058          integer,intent(in)::id_varid
00059          integer,intent(out)::ierror
00060 !
00061 !        Local variables
00062 !
00063          integer::ierrp(2),j,i,il_gridid,icnt
00064          integer::isize_in,isize_out,isize_tasks
00065          integer::il_lag
00066         Character(len=len_cvs_string),save :: get_att_cvs= 
00067 '$Id: psmile_io_get.F90 2923 2011-01-27 15:43:13Z coquart $'
00068 
00069          ierror=0
00070 
00071 #ifdef __PSMILE_WITH_IO
00072 !
00073 #ifdef VERBOSE
00074             print*,trim(ch_id),' : psmile_io_get_info_init : start'
00075             call psmile_flushstd
00076 #endif
00077          il_smioc_loc=Fields(id_varid)%smioc_loc
00078          il_gridid=Methods(Fields(id_varid)%method_id)%grid_id
00079          il_smioc_index=0
00080 
00081          do i=1,iga_comp_nb_grids(1)
00082 #ifdef VERBOSE
00083            print*,trim(ch_id),' : psmile_io_get_info_init : ', &
00084                   trim(adjustl(Grids(il_gridid)%grid_name)) &
00085                  ,trim(adjustl(sga_smioc_grids(i)%cg_grid_name))
00086 #endif
00087            if(trim(adjustl(Grids(il_gridid)%grid_name)) .eq. &
00088               trim(adjustl(sga_smioc_grids(i)%cg_grid_name))) exit
00089          enddo
00090          if(i.le.iga_comp_nb_grids(1)) il_smioc_index=i
00091 
00092          if(il_smioc_index.eq.0 .or. &
00093             il_smioc_index.gt.iga_comp_nb_grids(1)) then
00094           ierror=PRISM_Error_IO_Meta
00095           ierrp(1)=id_varid
00096           call psmile_error(ierror,'Look-up of grid failed for varid: ', &
00097                            ierrp,1, __FILE__, __LINE__)
00098          endif
00099 !
00100 !        Allocate a I/O task lookup table
00101 !
00102          isize_in=0
00103          isize_out=0
00104          if(associated(sga_smioc_transi(il_smioc_loc) &
00105                        %sg_transi_in%sga_in_orig))    &
00106             isize_in=size(sga_smioc_transi(il_smioc_loc) &
00107                            %sg_transi_in%sga_in_orig)
00108          if(associated(sga_smioc_transi(il_smioc_loc)%sga_transi_out)) &
00109             isize_out=size(sga_smioc_transi(il_smioc_loc)%sga_transi_out)
00110 
00111          PRINT*, 'laure size_in, size_out :',isize_in, isize_out
00112 
00113 !
00114 !        We have 4 regions of task ids
00115 !        Offset 0: Usual I/O output channels.
00116 !        Offest  isize_out : Usual I/O input channel .
00117 !        Offset  isize_out+1: I/O output channels for debug 
00118 !        Offset  2*isize_out+1: I/O input channels for restarts
00119 !        Offset  3*isize_out+1: I/O output channels for restarts
00120 !
00121          isize_tasks=4*max(isize_in,isize_out)+1
00122          allocate(Fields(id_varid)%io_task_lookup(1:isize_tasks),stat=ierror)
00123 
00124          if(ierror.ne.0) then
00125            ierrp(1)=id_varid
00126            ierror = PRISM_Error_Alloc
00127            call psmile_error(ierror,'Allocation of io_task_lookup failed!', & 
00128                            ierrp,1, __FILE__, __LINE__)
00129          endif
00130 
00131          Fields(id_varid)%io_task_lookup=-1
00132 
00133 #ifdef VERBOSE
00134             print*,trim(ch_id),' : psmile_io_get_info_init : io_task_lookup( ' &
00135                               ,isize_tasks,') allocated!'
00136             call psmile_flushstd
00137 #endif
00138 !
00139 !        How many file I/O channels (dests or origines) are declared?
00140 !
00141           lread=.false.
00142           icnt=0
00143           if(associated(sga_smioc_transi(il_smioc_loc) &
00144                        %sg_transi_in%sga_in_orig)) then
00145             do i=1,size(sga_smioc_transi(il_smioc_loc)%sg_transi_in%sga_in_orig)
00146   
00147               if(sga_smioc_transi(il_smioc_loc) &
00148                  %sg_transi_in%sga_in_orig(i)%ig_orig_type.eq.PSMILe_File) then
00149 #ifdef VERBOSE
00150             print*,trim(ch_id),' : psmile_io_get_info_init : debug mode on read:' &
00151                               ,sga_smioc_transi(il_smioc_loc) &
00152                                %sg_transi_in%ig_debugmode
00153             call psmile_flushstd
00154 #endif
00155 
00156                    icnt=icnt+1
00157                    Fields(id_varid)%io_task_lookup(i)=icnt
00158   
00159 !rv                   if(trim(adjustl(sga_smioc_transi(il_smioc_loc) &
00160 !rv                                %sg_transi_in%sga_in_orig(i) &
00161 !rv                                %cg_orig_transi)) .eq. &
00162 !rv                      trim(adjustl(Fields(id_varid)%local_name))) then
00163                       lread=.true.
00164 !rv                   endif
00165   
00166               endif
00167 
00168             enddo
00169 #ifdef VERBOSE
00170             print*,trim(ch_id),' : psmile_io_get_info_init : ',icnt,' read channels'
00171             call psmile_flushstd
00172 #endif
00173           endif
00174 
00175           lwrite=.false.
00176           icnt=0
00177           if(associated(sga_smioc_transi(il_smioc_loc)%sga_transi_out)) then
00178             do i=1,size(sga_smioc_transi(il_smioc_loc)%sga_transi_out)
00179   
00180               if(sga_smioc_transi(il_smioc_loc) &
00181                  %sga_transi_out(i)%ig_dest_type.eq.PSMILe_File) then
00182   
00183                 icnt=icnt+1
00184                 Fields(id_varid)%io_task_lookup(i)=icnt
00185   
00186 !rv                if(trim(adjustl(sga_smioc_transi(il_smioc_loc) &
00187 !rv                              %sga_transi_out(i)%cg_transi_out_name)) .eq. &
00188 !rv                   trim(adjustl(Fields(id_varid)%local_name))) then
00189                    lwrite=.true.
00190 !rv                endif
00191   
00192               endif
00193   
00194             enddo
00195 #ifdef VERBOSE
00196             print*,trim(ch_id),' : psmile_io_get_info_init : ',icnt,' write channels'
00197             call psmile_flushstd
00198 #endif
00199           endif
00200 !
00201 !RV       Loop over output channels  to search for debug mode flags equal true.
00202 !RV       The file informations of the debug mode
00203 !RV       are stored within the I/O task lookup
00204 !RV       by an offset of size of sga_transi_out.
00205 !RV       2*size(sga_transi_out)+1 keeps 
00206 !RV       the infos for debugging the transient_in
00207 !RV       part.
00208 !
00209        
00210           ig_transiouts=0
00211           if(associated(sga_smioc_transi(il_smioc_loc)%sga_transi_out)) then
00212             ig_transiouts=size(sga_smioc_transi(il_smioc_loc)%sga_transi_out)
00213             do i=1,ig_transiouts
00214 
00215               if(sga_smioc_transi(il_smioc_loc) &
00216                  %sga_transi_out(i)%ig_debugmode.eq.PSMILe_true) then
00217 
00218                 icnt=icnt+1
00219                 Fields(id_varid)%io_task_lookup(ig_transiouts+i)=icnt
00220 
00221 !rv                if(trim(adjustl(sga_smioc_transi(il_smioc_loc) &
00222 !rv                             %sga_transi_out(i)%cg_transi_out_name)) .eq. &
00223 !rv                  trim(adjustl(Fields(id_varid)%local_name))) then
00224                    lwrite=.true.
00225 !rv                endif
00226 
00227               endif
00228 
00229             enddo
00230 #ifdef VERBOSE
00231             print*,trim(ch_id),' : psmile_io_get_info_init : ',icnt &
00232                             ,' write channels after debug on output transients' 
00233             call psmile_flushstd
00234 #endif
00235           endif
00236 !
00237 !         Last but not least, check if a  transient_in has a debug flag!
00238 !         If the transient_in is already comming from a file I am turning
00239 !         debug mode off.
00240 
00241           if(.not.lread) then
00242             if(sga_smioc_transi(il_smioc_loc) &
00243                %sg_transi_in%ig_debugmode .eq. PSMILe_true ) then
00244                icnt=icnt+1
00245                Fields(id_varid)%io_task_lookup(2*ig_transiouts+1)=icnt
00246                lwrite=.true.
00247             endif
00248           else
00249             if(sga_smioc_transi(il_smioc_loc) &
00250                %sg_transi_in%ig_debugmode .eq. PSMILe_true ) then
00251 
00252               ierrp(1)=id_varid
00253               call psmile_warning ( 0, 'Debug mode is turned  off for '// &
00254                                      'explicitely requested I/O read action!', &
00255                                       ierrp, 1, __FILE__, __LINE__ )
00256             endif
00257           endif
00258 #ifdef VERBOSE
00259             print*,trim(ch_id),' : psmile_io_get_info_init : ',icnt &
00260             ,'write channels after debug on output and input transients' 
00261             print*,trim(ch_id),' : psmile_io_get_info_init : lread=',lread, &
00262                                ' lwrite=',lwrite
00263             call psmile_flushstd
00264 #endif
00265 !
00266 !         Check if a restart has to be performed  potentially on one of
00267 !         of the fields.
00268 !
00269           ig_transiouts=0
00270           llag=.false.
00271           if(associated(sga_smioc_transi(il_smioc_loc)%sga_transi_out)) then
00272             ig_transiouts=size(sga_smioc_transi(il_smioc_loc)%sga_transi_out)
00273             do i=1,ig_transiouts
00274 
00275               il_lag = &
00276                       sga_smioc_transi(il_smioc_loc)%sga_transi_out(i)%ig_lag
00277 
00278 !rv Just to trigger some action.
00279 !!!!              il_lag=1
00280 
00281 !rv
00282 !rv             if ( il_lag /= PSMILe_undef .and. il_lag /= 0 ) then
00283 !rv           I permit a zero lag in order to trigger the initialization
00284 !rv           of the I/O informations. Thusprism_put_restart can be used.
00285 !rv
00286               if ( il_lag /= PSMILe_undef .and. il_lag >= 0 ) then
00287                 llag=.true.
00288                 icnt=icnt+1
00289                 Fields(id_varid)%io_task_lookup(2*ig_transiouts+1+i)=icnt
00290                 icnt=icnt+1
00291                 Fields(id_varid)%io_task_lookup(3*ig_transiouts+1+i)=icnt
00292 
00293               endif
00294 
00295 
00296             enddo
00297 #ifdef VERBOSE
00298             print*,trim(ch_id),' : psmile_io_get_info_init : ',icnt &
00299                             ,' channels after restart. lag= ',  llag
00300             call psmile_flushstd
00301 #endif
00302           endif
00303 
00304 
00305 
00306           Nullify(Fields(id_varid)%io_chan_infos)
00307 
00308           if(lread.and.lwrite) then
00309             ierror=PRISM_Error_IO_Meta
00310             ierrp(1)=id_varid
00311             call psmile_error(ierror,'Variable is simultaneously ' &
00312                                      //'used for input and output', &
00313                               ierrp,1, __FILE__, __LINE__)
00314 
00315           else if(lread .or. lwrite .or. llag) then
00316 
00317             icnt=-1
00318             do i=1,size(Fields(id_varid)%io_task_lookup)
00319               icnt=max(icnt,Fields(id_varid)%io_task_lookup(i))
00320             enddo
00321 
00322             allocate(Fields(id_varid)%io_chan_infos(1:icnt),stat=ierror)
00323             if(ierror.ne.0) then
00324               ierrp(1)=id_varid
00325               ierror = PRISM_Error_Alloc
00326               call psmile_error(ierror,'Allocation of io_chan_infos failed! ', &
00327                             ierrp,1, __FILE__, __LINE__)
00328             else
00329 #ifdef VERBOSE
00330             print*,trim(ch_id),' : psmile_io_get_info_init : io_chan_infos('&
00331                                ,icnt,') allocated!' 
00332             call psmile_flushstd
00333 #endif
00334             endif
00335 !
00336 !           Nullify substructures and pointers
00337 !
00338 
00339             do i=1,icnt
00340               Nullify(Fields(id_varid)%io_chan_infos(i)%p_cf_names)
00341               Nullify(Fields(id_varid)%io_chan_infos(i)%p_cf_maps)
00342               Nullify(Fields(id_varid)%io_chan_infos(i)%p_cache)
00343               Nullify(Fields(id_varid)%io_chan_infos(i)%p_mpp_io)
00344             enddo
00345 
00346             do j=1,icnt 
00347 !
00348 !             Allocate character field to store component names of vector fields
00349 !
00350               if(sga_smioc_transi(il_smioc_loc)%ig_transi_type &
00351                 .eq.PSMILe_vector) then
00352                 i=size(sga_smioc_transi(il_smioc_loc)%cga_stand_name)
00353               else
00354                 i=1
00355               endif
00356 
00357               allocate(Fields(id_varid)%io_chan_infos(j)%vcmp_names(i) &
00358                       ,stat=ierror)
00359 
00360               Fields(id_varid)%io_chan_infos(j)%vcmp_names=' '
00361 
00362               if(ierror.ne.0) then
00363                 ierrp(1)=id_varid
00364                 ierrp(2)=i
00365                 ierror = PRISM_Error_Alloc
00366                 call psmile_error(ierror &
00367                            ,'Allocation of io_chan_infos%vcmp_names failed! ' &
00368                            , ierrp,2, __FILE__, __LINE__)
00369               endif
00370 !
00371 !             Allocate character field to store the labels of the items
00372 !             of bundles
00373 !
00374               if(sga_smioc_transi(il_smioc_loc)%ig_transi_type &
00375                 .eq.PSMILe_bundle)then
00376 
00377                  i=size(sga_smioc_transi(il_smioc_loc)%cga_stand_name)
00378 
00379                  if(i.le.1) then
00380                     ierror=PRISM_Error_IO_Meta
00381                     ierrp(1)=id_varid
00382                     call psmile_error(ierror,'Labels of bundles are missing!', &
00383                                 ierrp,1, __FILE__, __LINE__)
00384                  endif
00385               else
00386                  i=1
00387               endif
00388 
00389               allocate(Fields(id_varid)%io_chan_infos(j)%labels(i-1) &
00390                       ,stat=ierror)
00391 
00392               if(ierror.ne.0) then
00393                 ierrp(1)=id_varid
00394                 ierrp(2)=i-1
00395                 ierror = PRISM_Error_Alloc
00396                 call psmile_error(ierror,'Allocation of labels failed! ', &
00397                             ierrp,2, __FILE__, __LINE__)
00398               endif
00399 
00400 
00401             enddo
00402 
00403           endif
00404 
00405 #ifdef VERBOSE
00406             print*,trim(ch_id),' : psmile_io_get_info_init : end'
00407             call psmile_flushstd
00408 #endif
00409 
00410 #endif
00411         end subroutine psmile_io_get_info_init
00412 
00413     subroutine psmile_io_get_info_i4(id_varid,tskid,id_inqid,id_ival,ierror)
00414 !-----------------------------------------------------------------------
00415         use psmile
00416         use psmile_io_utils
00417         use PSMILe_SMIOC, only : sga_smioc_transi,sga_smioc_grids
00418 !
00419         implicit none
00420         include 'prism.inc'
00421     integer,intent(in)::id_varid,tskid,id_inqid
00422         integer,intent(out)::id_ival
00423         integer,intent(out)::ierror
00424 !Local declarations
00425         integer:: ierrp(1),i,icnt
00426         logical:: ldebug
00427         Character(len=len_cvs_string),save :: get_att_cvs= 
00428 '$Id: psmile_io_get.F90 2923 2011-01-27 15:43:13Z coquart $'
00429 
00430         ierror=0
00431         id_ival=0
00432 
00433 #ifdef __PSMILE_WITH_IO
00434         if(lread) il_in_loc=tskid
00435         if(lwrite) il_out_loc=tskid
00436 
00437 !
00438 !           The taskid is in the range of the size of transient out.
00439 !           Moreover, lwrite is true => the user has declared explicitely
00440 !           a file as a destination. Taskids higher then that size
00441 !           are for debugging
00442 !
00443         ldebug=.true.
00444         if(lwrite.and.tskid.le.ig_transiouts) ldebug=.false.
00445 !
00446         Select Case (id_inqid) 
00447         Case (PSMILe_IO_GET_FILEUNIT)
00448           call psmile_io_fileunit(id_varid,id_ival,ierror)
00449         Case (PSMILe_IO_GET_ACTION)
00450 
00451 
00452           id_ival=PSMILe_Status_undefined
00453           if(lwrite.and.lread) then
00454             ierror=PRISM_Error_IO_Meta
00455             ierrp(1)=id_inqid
00456             call psmile_error(ierror,'Variable is simultaneously ' &
00457                                      //'used for input and output', &
00458                               ierrp,1, __FILE__, __LINE__)
00459           elseif(lwrite) then
00460             id_ival = MPP_OVERWR
00461           elseif(lread)  then
00462            id_ival = MPP_RDONLY
00463           endif
00464 
00465           if(llag .and. tskid.gt.(2*ig_transiouts+1) &
00466                   .and. tskid.le.(3*ig_transiouts+1) ) then
00467             id_ival = MPP_RDONLY
00468           endif
00469 
00470           if(llag .and. tskid.gt.(3*ig_transiouts+1) &
00471                   .and. tskid.le.(4*ig_transiouts+1) ) then
00472             id_ival = MPP_OVERWR
00473           endif
00474 
00475         Case (PSMILe_IO_GET_FORMAT)
00476           if(lread) then
00477             Select Case (sga_smioc_transi(il_smioc_loc) &
00478                          %sg_transi_in%sga_in_orig(il_in_loc)%sg_orig_file &
00479                          %ig_file_format)
00480             Case(PSMILe_mpp_netcdf)
00481               id_ival=MPP_NETCDF
00482             Case Default
00483               ierror=PRISM_Error_IO_Meta
00484               ierrp(1)=id_inqid
00485               call psmile_error(ierror,'Only NetCDF format is allowed for' &
00486                                      //' input!', &
00487                               ierrp,1, __FILE__, __LINE__)
00488             End Select
00489 
00490           elseif(lwrite) then
00491             if(.not.ldebug) then
00492               Select Case (sga_smioc_transi(il_smioc_loc) &
00493                            %sga_transi_out(il_out_loc)%sg_dest_file &
00494                            %ig_file_format)
00495               Case(PSMILe_mpp_netcdf)
00496                 id_ival=MPP_NETCDF
00497               Case(PSMILe_mpp_native)
00498                 id_ival=MPP_NATIVE
00499               Case(PSMILe_mpp_ieee32)
00500                 id_ival=MPP_IEEE32
00501               Case(PSMILe_mpp_ascii)
00502                 id_ival=MPP_ASCII
00503               Case Default
00504                 ierror=PRISM_Error_IO_Meta
00505                 ierrp(1)=id_inqid
00506                 call psmile_error(ierror,'Unknown file format for output!', &
00507                                 ierrp,1, __FILE__, __LINE__)
00508               End Select
00509             else
00510               id_ival=MPP_NETCDF
00511             endif
00512           endif
00513           if(llag .and. tskid.gt.(2*ig_transiouts+1) &
00514                   .and. tskid.le.(4*ig_transiouts+1) ) then
00515             id_ival = MPP_NETCDF
00516           endif
00517         Case (PSMILe_IO_GET_FILESET)
00518 
00519            if(lread) then
00520             i=sga_smioc_transi(il_smioc_loc) &
00521                          %sg_transi_in%sga_in_orig(il_in_loc)%sg_orig_file &
00522                          %ig_file_iomode
00523            endif
00524 
00525            if(lwrite) then
00526              if(.not.ldebug) then
00527               i=sga_smioc_transi(il_smioc_loc) &
00528                          %sga_transi_out(il_out_loc)%sg_dest_file%ig_file_iomode
00529              else
00530               i=PSMILe_iosingle
00531              endif
00532            endif
00533            if(llag .and. tskid.gt.(2*ig_transiouts+1) &
00534                   .and. tskid.le.(4*ig_transiouts+1) ) then
00535              i=PSMILe_iosingle
00536            endif
00537 
00538 #ifdef __PARNETCDF
00539            i=PSMILe_parallel
00540 #endif
00541 
00542 !            print*,'###### io_mode',i
00543            Select Case (i)
00544            Case(PSMILe_iosingle)
00545              id_ival = MPP_SINGLE
00546            Case(PSMILe_distributed)
00547              id_ival = MPP_MULTI
00548            Case(PSMILe_parallel)
00549              id_ival = MPP_PARALLEL
00550 !rr             ierrp (1) = i
00551 !rr             ierror =  PRISM_Error_IO_Meta
00552 !rr             call PSMILe_Error ( ierror, 'Parallel I/O not yet supported!', &
00553 !rr                           ierrp, 1, __FILE__, __LINE__ )
00554 !rr             return
00555            Case DEFAULT
00556              ierrp (1) = i
00557              ierror =  PRISM_Error_IO_Meta
00558              call psmile_error ( ierror, 'I/O mode unknown! ', &
00559                            ierrp, 1, __FILE__, __LINE__ )
00560              return
00561            End Select
00562 
00563         Case (PSMILe_IO_GET_THREADING)
00564 
00565            if(lread) then
00566             i=sga_smioc_transi(il_smioc_loc) &
00567                          %sg_transi_in%sga_in_orig(il_in_loc)%sg_orig_file &
00568                          %ig_file_iomode
00569            endif
00570 
00571            if(lwrite) then
00572              if(.not.ldebug) then
00573               i=sga_smioc_transi(il_smioc_loc) &
00574                          %sga_transi_out(il_out_loc)%sg_dest_file%ig_file_iomode
00575              else
00576               i=PSMILe_iosingle
00577              endif
00578            endif
00579            if(llag .and. tskid.gt.(2*ig_transiouts+1) &
00580                   .and. tskid.le.(4*ig_transiouts+1) ) then
00581              i=PSMILe_iosingle
00582            endif
00583 
00584 #ifdef __PARNETCDF
00585            i=PSMILe_parallel
00586 #endif
00587 !            print*,'###### io_mode',i
00588            Select Case (i)
00589            Case(PSMILe_iosingle)
00590              id_ival = MPP_SINGLE
00591            Case(PSMILe_distributed)
00592              id_ival = MPP_MULTI
00593            Case(PSMILe_parallel)
00594              id_ival = MPP_PARALLEL
00595 !rr             ierrp (1) = i
00596 !rr             ierror =  PRISM_Error_IO_Meta
00597 !rr             call PSMILe_Error ( ierror, 'Parallel I/O not yet supported!', &
00598 !rr                           ierrp, 1, __FILE__, __LINE__ )
00599 !rr             return
00600            Case DEFAULT
00601              ierrp (1) = i
00602              ierror =  PRISM_Error_IO_Meta
00603              call psmile_error ( ierror, 'I/O mode unknown! ', &
00604                            ierrp, 1, __FILE__, __LINE__ )
00605              return
00606            End Select
00607 
00608         Case (PSMILe_IO_GET_PACK)
00609           if(lread) then
00610             i=sga_smioc_transi(il_smioc_loc) &
00611                          %sg_transi_in%sga_in_orig(il_in_loc)%sg_orig_file &
00612                          %ig_file_pack
00613           elseif(lwrite) then
00614             if(.not.ldebug) then
00615               i=sga_smioc_transi(il_smioc_loc) &
00616                          %sga_transi_out(il_out_loc)%sg_dest_file%ig_file_pack
00617             else
00618               i=-1
00619             endif
00620           elseif(llag) then
00621           else
00622               ierror=PRISM_Error_IO_Meta
00623               ierrp(1)=id_inqid
00624               call psmile_error(ierror,'Could not extract pack mode!', &
00625                               ierrp,1, __FILE__, __LINE__)
00626           endif
00627           if(llag .and. tskid.gt.(2*ig_transiouts+1) &
00628                   .and. tskid.le.(4*ig_transiouts+1) ) then
00629              i=-1
00630           endif
00631 
00632 
00633           Select Case(i)
00634           Case(PSMILe_one)
00635             id_ival=PSMILe_one
00636           Case(PSMILe_two)
00637             id_ival=PSMILe_two
00638           Case(PSMILe_four)
00639             id_ival=PSMILe_four
00640           Case(PSMILe_eight)
00641             id_ival=PSMILe_eight
00642           Case Default
00643             select case(Fields(id_varid)%datatype)
00644             case(PRISM_Integer)
00645               id_ival=2
00646             case(PRISM_Logical)
00647               id_ival=2
00648             case(PRISM_Real)
00649               id_ival=2
00650             case(PRISM_Double_Precision)
00651               id_ival=1
00652             case DEFAULT
00653              ierrp (1) = Fields(id_varid)%datatype
00654              ierror =  PRISM_Error_IO_Meta
00655              call psmile_error ( ierror, 'Data type not yet supported!', &
00656                            ierrp, 1, __FILE__, __LINE__ )
00657              return
00658 
00659             end select
00660 
00661           End Select
00662           
00663         Case (PSMILe_IO_GET_TYPE_SPEC)
00664           id_ival =Fields(id_varid)%datatype
00665         Case (PSMILe_IO_GET_LAGMODE)
00666           if(lread) then
00667             id_ival=sga_smioc_transi(il_smioc_loc) &
00668                          %sg_transi_in%ig_tgt_timeop
00669 
00670           else
00671             id_ival =PRISM_Undefined
00672           endif
00673         Case (PSMILe_IO_GET_SUFFIX)
00674           if(lread) then
00675             id_ival=sga_smioc_transi(il_smioc_loc) &
00676                          %sg_transi_in%sga_in_orig(il_in_loc)%sg_orig_file &
00677                          %ig_suffix
00678           elseif(lwrite) then
00679             if(.not.ldebug) then
00680               id_ival=sga_smioc_transi(il_smioc_loc) &
00681                          %sga_transi_out(il_out_loc)%sg_dest_file%ig_suffix
00682             else
00683               id_ival=PSMILE_true
00684             endif
00685           elseif(llag) then
00686           else
00687               ierror=PRISM_Error_IO_Meta
00688               ierrp(1)=id_inqid
00689               call psmile_error(ierror,'Could not extract pack mode!', &
00690                               ierrp,1, __FILE__, __LINE__)
00691           endif
00692           if(llag .and. tskid.gt.(2*ig_transiouts+1) &
00693                   .and. tskid.le.(4*ig_transiouts+1) ) then
00694 !
00695 !           In case of restart files I don't allow for automatic file name
00696 !           construction
00697 !
00698             id_ival=PSMILE_false
00699           endif
00700 
00701         Case DEFAULT
00702         
00703          ierror=PRISM_Error_IO_Meta
00704          ierrp(1)=id_inqid
00705          call psmile_error(ierror,'Wrong inquiry made', &
00706                            ierrp,1, __FILE__, __LINE__)
00707 
00708         End Select
00709 #endif
00710 
00711         return
00712         end subroutine psmile_io_get_info_i4
00713 
00714     subroutine psmile_io_get_info_i41(varid,tskid,inqid,ival,ierror)
00715 !-----------------------------------------------------------------------
00716         use psmile
00717         implicit none
00718     integer,intent(in)::varid,tskid,inqid
00719         integer,intent(out)::ival(:)
00720         integer,intent(out)::ierror
00721 
00722         ierror=0
00723         ival=0
00724 
00725 #ifdef __PSMILE_WITH_IO
00726         if(lread) il_in_loc=tskid
00727         if(lwrite) il_out_loc=tskid
00728 #endif
00729         return
00730         end subroutine psmile_io_get_info_i41
00731 
00732         subroutine psmile_io_get_info_r8(id_varid,tskid,id_inqid,rval,ierror)
00733 !-----------------------------------------------------------------------
00734         use psmile
00735         use PSMILe_SMIOC, only : sga_smioc_transi,sga_smioc_grids
00736         implicit none
00737         include 'prism.inc'
00738     integer,intent(in)::id_varid,tskid,id_inqid
00739         double precision,intent(out)::rval
00740         integer,intent(out)::ierror
00741         logical::ldebug
00742 !Local declarations
00743         integer ierrp(1)
00744 
00745         ierror=0
00746         rval=0
00747 
00748 #ifdef __PSMILE_WITH_IO
00749         if(lread) il_in_loc=tskid
00750         if(lwrite) il_out_loc=tskid
00751         ldebug=.true.
00752         if(lwrite.and.tskid.le.ig_transiouts) ldebug=.false.
00753 
00754         Select Case (id_inqid)
00755         Case(PSMILe_IO_GET_SCALE)
00756           rval=1.
00757           if(lread) then
00758             rval=sga_smioc_transi(il_smioc_loc) &
00759                          %sg_transi_in%sga_in_orig(il_in_loc)%sg_orig_file &
00760                          %dg_file_scal
00761           elseif(lwrite) then
00762             if(.not.ldebug) then
00763             rval=sga_smioc_transi(il_smioc_loc) &
00764                          %sga_transi_out(il_out_loc)%sg_dest_file%dg_file_scal
00765             endif
00766           elseif(llag) then
00767           else
00768               ierror=PRISM_Error_IO_Meta
00769               ierrp(1)=id_inqid
00770               call psmile_error(ierror,'Could not extract scale factor!', &
00771                               ierrp,1, __FILE__, __LINE__)
00772           endif
00773           if(llag .and. tskid.gt.(2*ig_transiouts+1) &
00774                   .and. tskid.le.(4*ig_transiouts+1) ) then
00775             rval=1.
00776           endif
00777 
00778         Case(PSMILe_IO_GET_ADD)
00779 
00780           rval=0.
00781           if(lread) then
00782             rval=sga_smioc_transi(il_smioc_loc) &
00783                          %sg_transi_in%sga_in_orig(il_in_loc)%sg_orig_file &
00784                          %dg_file_add
00785           elseif(lwrite) then
00786             if(.not.ldebug) then
00787             rval=sga_smioc_transi(il_smioc_loc) &
00788                          %sga_transi_out(il_out_loc)%sg_dest_file%dg_file_add
00789             endif
00790           elseif(llag) then
00791           else
00792               ierror=PRISM_Error_IO_Meta
00793               ierrp(1)=id_inqid
00794               call psmile_error(ierror,'Could not extract constant !', &
00795                               ierrp,1, __FILE__, __LINE__)
00796           endif
00797           if(llag .and. tskid.gt.(2*ig_transiouts+1) &
00798                   .and. tskid.le.(4*ig_transiouts+1) ) then
00799             rval=1.
00800           endif
00801 
00802         Case(PSMILe_IO_GET_VALID_MIN)
00803 
00804           rval=-1.e35
00805           rval=sga_smioc_transi(il_smioc_loc)%dg_transi_min
00806           if(abs(rval-PSMILe_dundef).lt.1.e-14) rval=-1.e35
00807 
00808         Case(PSMILe_IO_GET_VALID_MAX)
00809 
00810           rval=1.e35
00811           rval=sga_smioc_transi(il_smioc_loc)%dg_transi_max
00812           if(abs(rval-PSMILe_dundef).lt.1.e-14) rval= 1.e35
00813 
00814         Case(PSMILe_IO_GET_FILL)
00815 
00816           rval=def_init_val
00817           if(lread) then
00818             rval=sga_smioc_transi(il_smioc_loc) &
00819                          %sg_transi_in%sga_in_orig(il_in_loc)%sg_orig_file &
00820                          %dg_fill_val
00821 
00822           elseif(lwrite) then
00823             if(.not.ldebug) then
00824               rval=sga_smioc_transi(il_smioc_loc) &
00825                          %sga_transi_out(il_out_loc)%sg_dest_file%dg_fill_val
00826             endif
00827           elseif(llag)then
00828           else
00829               ierror=PRISM_Error_IO_Meta
00830               ierrp(1)=id_inqid
00831               call psmile_error(ierror,'Could not extract fill value!', &
00832                               ierrp,1, __FILE__, __LINE__)
00833           endif
00834           if(rval.le.sga_smioc_transi(il_smioc_loc)%dg_transi_max .and.  &
00835              rval.ge.sga_smioc_transi(il_smioc_loc)%dg_transi_min) &
00836             rval=def_init_val
00837 
00838           if(llag .and. tskid.gt.(2*ig_transiouts+1) &
00839                   .and. tskid.le.(4*ig_transiouts+1) ) then
00840             rval=def_init_val
00841           endif
00842         Case(PSMILe_IO_GET_MISSING)
00843 
00844            rval=PSMILe_dundef
00845           if(lread) then
00846             rval=sga_smioc_transi(il_smioc_loc) &
00847                          %sg_transi_in%sga_in_orig(il_in_loc)%sg_orig_file &
00848                          %dg_fill_val
00849           elseif(lwrite) then
00850             if(.not.ldebug) then
00851             rval=sga_smioc_transi(il_smioc_loc) &
00852                          %sga_transi_out(il_out_loc)%sg_dest_file%dg_fill_val
00853             endif
00854           elseif(llag)then
00855           else
00856               ierror=PRISM_Error_IO_Meta
00857               ierrp(1)=id_inqid
00858               call psmile_error(ierror,'Could not extract fill value!', &
00859                               ierrp,1, __FILE__, __LINE__)
00860           endif
00861           if(rval.le.sga_smioc_transi(il_smioc_loc)%dg_transi_max .and.  &
00862              rval.ge.sga_smioc_transi(il_smioc_loc)%dg_transi_min) &
00863             rval=1.e36
00864 
00865           if(llag .and. tskid.gt.(2*ig_transiouts+1) &
00866                   .and. tskid.le.(4*ig_transiouts+1) ) then
00867             rval=1e36
00868           endif
00869         Case(PSMILe_IO_GET_LAGWEIGHT)
00870 
00871           rval=PRISM_Undefined
00872 
00873 
00874         Case Default
00875 
00876           ierror=PRISM_Error_IO_Meta
00877           ierrp(1)=id_inqid
00878           call psmile_error(ierror,'Wrong inquiry made', &
00879                            ierrp,1, __FILE__, __LINE__)
00880         End select
00881 
00882 #endif
00883         return
00884         end subroutine psmile_io_get_info_r8
00885 
00886 
00887         subroutine psmile_io_get_info_r81(varid,tskid,inqid,rval,ierror)
00888 !-----------------------------------------------------------------------
00889         use psmile
00890         implicit none
00891     integer,intent(in)::varid,tskid,inqid
00892         double precision,intent(out)::rval(:)
00893         integer,intent(out)::ierror
00894         logical::ldebug
00895 
00896         ierror=0
00897         rval=0.0
00898 #ifdef __PSMILE_WITH_IO
00899         if(lread) il_in_loc=tskid
00900         if(lwrite) il_out_loc=tskid
00901 #endif
00902 
00903         return
00904         end subroutine psmile_io_get_info_r81
00905 
00906     subroutine psmile_io_get_info_ch(id_varid,tskid,id_inqid,cval,ierror)
00907 !-----------------------------------------------------------------------
00908         use psmile
00909         use PSMILe_SMIOC, only : sga_smioc_transi,sga_smioc_grids &
00910                                , iga_comp_nb_grids
00911         use PRISM_Constants
00912         use psmile_io_utils
00913 
00914         implicit none
00915 
00916     integer,intent(in)::id_varid,tskid,id_inqid
00917         character(LEN=*),intent(out)::cval
00918         integer,intent(out)::ierror
00919 ! Local variables:
00920         Type(PRISM_Time_Struct):: local_date
00921         character(len=max_name)::cl_string
00922         integer,dimension(6)::il_date
00923 
00924         integer     :: ierrp(1)
00925         logical::ldebug
00926 
00927         ierror=0
00928 
00929 #ifdef __PSMILE_WITH_IO
00930         if(lread) il_in_loc=tskid
00931         if(lwrite) il_out_loc=tskid
00932         ldebug=.true.
00933         if(lwrite.and.tskid.le.ig_transiouts) ldebug=.false.
00934 
00935         Select Case(id_inqid)
00936         Case  (PSMILe_IO_GET_FILENAME)
00937 !          cval=trim(Fields(id_varid)%local_name)//'.nc'
00938           cval=trim(Fields(id_varid)%local_name)
00939           if(lread) then
00940             cval=sga_smioc_transi(il_smioc_loc) &
00941                          %sg_transi_in%sga_in_orig(il_in_loc)%sg_orig_file &
00942                          %cg_file_name
00943           elseif(lwrite) then
00944             if(.not.ldebug) then
00945               cval=sga_smioc_transi(il_smioc_loc) &
00946                          %sga_transi_out(il_out_loc)%sg_dest_file%cg_file_name
00947             else
00948               if(tskid.eq.(2*ig_transiouts+1)) then
00949                 cval=trim(Fields(id_varid)%local_name)//'_getg'
00950               else
00951                 cval=trim(Fields(id_varid)%local_name)//'_putg'
00952               endif
00953             endif
00954 
00955           elseif(llag)then
00956           else
00957               ierror=PRISM_Error_IO_Meta
00958               ierrp(1)=id_inqid
00959               call psmile_error(ierror,'Could not extract file name!', &
00960                               ierrp,1, __FILE__, __LINE__)
00961           endif
00962           if(llag) then
00963 !
00964 !    For the restart a job reads fields for which a time lag
00965 !    was declared from a file <local name>_rst.<jobstart date in ISO format>.nc
00966 !
00967             if(tskid.gt.(2*ig_transiouts+1) &
00968                     .and. tskid.le.(3*ig_transiouts+1) ) then
00969 
00970                cl_string=trim(Fields(id_varid)%local_name)//'_'// &
00971                          trim(Appl%name)//'_'//                   &
00972                          trim(Comps(Fields(id_varid)%comp_id)%comp_name)
00973 
00974                call psmile_io_get_jobstart_date(local_date,il_date,ierror)
00975                call combine_with_date(trim(cl_string) &
00976                                      ,'rst',il_date, cval)
00977              
00978             endif
00979 !
00980 !    For the restart a job writes fields for which a time lag
00981 !    was declared to a file <local name>_rst.<jobend date in ISO format>.nc
00982 !
00983 
00984             if(tskid.gt.(3*ig_transiouts+1) &
00985                     .and. tskid.le.(4*ig_transiouts+1) ) then
00986 
00987               cl_string=trim(Fields(id_varid)%local_name)//'_'// &
00988                          trim(Appl%name)//'_'//                   &
00989                          trim(Comps(Fields(id_varid)%comp_id)%comp_name)
00990 
00991               call psmile_io_get_jobend_date(local_date,il_date,ierror)
00992               call combine_with_date(trim(cl_string) &
00993                                     ,'rst',il_date, cval)
00994             endif
00995           endif
00996 
00997         Case  (PSMILe_IO_GET_CFLNGNAME)
00998           cval=trim(adjustl(sga_smioc_transi(il_smioc_loc)%cg_long_name))
00999           if(len(trim(cval)) .eq.0) cval=trim(Fields(id_varid)%local_name)
01000         Case  (PSMILe_IO_GET_CFSHRTNAME)
01001           cval=trim(adjustl(sga_smioc_transi(il_smioc_loc)%cga_stand_name(1)))
01002         Case  (PSMILe_IO_GET_CFUNITS)
01003           cval=trim(adjustl(sga_smioc_transi(il_smioc_loc)%cg_units))
01004 
01005         Case  (PSMILe_IO_GET_CFIONAME)
01006           if(lread) then
01007             cval=trim(adjustl(sga_smioc_transi(il_smioc_loc) &
01008                          %sg_transi_in%sga_in_orig(il_in_loc)%cg_orig_transi))
01009           elseif(lwrite) then
01010             if(.not.ldebug) then
01011               cval=trim(adjustl(sga_smioc_transi(il_smioc_loc) &
01012                          %sga_transi_out(il_out_loc)%cg_dest_transi))
01013             else
01014               cval=trim(adjustl(Fields(id_varid)%local_name))
01015             endif
01016           elseif(llag)then
01017           else
01018               ierror=PRISM_Error_IO_Meta
01019               ierrp(1)=id_inqid
01020               call psmile_error(ierror,'Could not in/out variable name!', &
01021                               ierrp,1, __FILE__, __LINE__)
01022           endif
01023           if(llag .and. tskid.gt.(2*ig_transiouts+1) &
01024                   .and. tskid.le.(4*ig_transiouts+1) ) then
01025             cval=trim(adjustl(Fields(id_varid)%local_name))
01026           endif
01027 
01028         Case Default
01029 
01030           ierror=PRISM_Error_IO_Meta
01031           ierrp(1)=id_inqid
01032           call psmile_error(ierror,'Wrong inquiry made', &
01033                            ierrp,1, __FILE__, __LINE__)
01034         End select
01035 
01036 #endif
01037         return
01038         end subroutine psmile_io_get_info_ch
01039         
01040     subroutine psmile_io_get_info_ch1(id_varid,tskid,id_inqid,cval,ierror)
01041 !-----------------------------------------------------------------------
01042         use psmile
01043         use PSMILe_SMIOC , only : sga_smioc_transi,sga_smioc_grids &
01044                                , iga_comp_nb_grids
01045         implicit none
01046         include 'prism.inc'
01047     integer,intent(in)::id_varid,tskid,id_inqid
01048         character(LEN=*),intent(out)::cval(:)
01049         integer,intent(out)::ierror
01050 ! Local variables:
01051         integer     :: ierrp(2),i,j
01052 
01053 
01054         ierror=0
01055 
01056 #ifdef __PSMILE_WITH_IO
01057         if(lread) il_in_loc=tskid
01058         if(lwrite) il_out_loc=tskid
01059 
01060         Select Case(id_inqid)
01061         Case (PSMILe_IO_GET_VCMPNAMES)
01062 
01063          if(sga_smioc_transi(il_smioc_loc)%ig_transi_type.eq.PSMILe_vector)then
01064            i=size(sga_smioc_transi(il_smioc_loc)%cga_stand_name)
01065            if(i.gt.1) then
01066              do j=1,i
01067 
01068                   cval(j)= &
01069                   trim(adjustl(sga_smioc_transi(il_smioc_loc) &
01070                         %cga_stand_name(j)))
01071              enddo
01072            endif
01073          endif
01074 
01075         Case (PSMILE_IO_GET_BNDLNAMES)
01076 
01077 !
01078 !        The first string of cga_stand_name is the generic  standard name.
01079 !        The follow-ons are the labels of the bundles. Example:
01080 !        surface temperature, surface_temperature_over_land, 
01081 !        surface_temperature_over_sea
01082 !       
01083 !        
01084          if(sga_smioc_transi(il_smioc_loc)%ig_transi_type.eq.PSMILe_bundle)then
01085            i=size(sga_smioc_transi(il_smioc_loc)%cga_stand_name)
01086            if(i.gt.1) then
01087              do j=1,i-1
01088                cval(j)= &
01089                      trim(adjustl(sga_smioc_transi(il_smioc_loc) &
01090                         %cga_stand_name(j+1)))
01091              enddo
01092            else
01093              ierror=PRISM_Error_IO_Meta
01094              ierrp(1)=id_varid
01095              call psmile_error(ierror,'Labels of bundles are missing!', &
01096                            ierrp,1, __FILE__, __LINE__)
01097            endif
01098          endif
01099 
01100         Case Default
01101 
01102           ierror=PRISM_Error_IO_Meta
01103           ierrp(1)=id_inqid
01104           call psmile_error(ierror,'Wrong inquiry made', &
01105                            ierrp,1, __FILE__, __LINE__)
01106         End select
01107 #endif
01108     end subroutine psmile_io_get_info_ch1
01109 end module psmile_io_get