psmile_enddef_metadata.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2006-2010, SGI Germany, Munich, Germany.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
! !ROUTINE: PSMILE_Enddef_Metadata
! !INTERFACE:
      subroutine psmile_enddef_metadata ( ierror )

! !USES:
      use PSMILe, dummy_interface => PSMILE_Enddef_Metadata
      use psmile_io_utils,only:indexi

      implicit none
      include 'prism.inc' 
! !OUTPUT PARAMETERS:
      integer, Intent (Out)               :: ierror

!
! !LOCAL VARIABLES:
!
      integer                             :: ierrp(2)
      integer                         :: ii,no_of_io_fields
      integer                         :: itemp_id,ino_of_glob_grids
      integer                             :: jj,kk,iid
      integer                             :: ino_of_items
      integer                             :: ilp,il_tskid
      integer                             :: icltn
      integer,allocatable                 :: itemp(:)
      integer,allocatable                 :: itemp1(:)
      integer,allocatable                 :: ivar_ids(:)
      integer,allocatable                 :: iglobal_grid_ids(:)
      integer,allocatable                 :: indices(:)
      integer,allocatable                 :: ino_grids(:)
      character(len=max_name)              :: cl_temp_name
!
! !DESCRIPTION:
!  
! 0th) Creates a table of related id's per var_id in case of a GME grid.
! 1st) Defines domain partitioning informations.
! 2nd) Open files.
! 3rd) Writes metadata informations to files.
!
! !REVISION HISTORY:
! 
!   Date      Programmer    Description
! ----------  -----------   -----------
! 31.10.2003  R. Vogelsang  created
! 09.12.2003  R. Vogelsang  call to psmile_write_meta inserted
! 21.06.2004  R. Vogelsang  Correction of the construction of the table of
!                           related IDs.  
! ---------------------------------------------------------------------
!EOP
      Character(len=len_cvs_string),save :: def_meta_cvs= 
'$Id: psmile_enddef_metadata.F90 2687 2010-10-28 15:15:52Z coquart $'

      ierror = 0
#ifdef __PSMILE_WITH_IO
#ifdef VERBOSE
      print*,trim(ch_id),' : psmile_enddef_metadata: start'
      call psmile_flushstd
#endif
!
!RV   Loop over var_ids find all associated grid_ids belonging to a certain
!RV   global_grid_id
!
      allocate(ivar_ids(Number_of_fields_allocated),stat=ierror)
      allocate(iglobal_grid_ids(Number_of_fields_allocated),stat=ierror)

      no_of_io_fields=0
      do ii=1,Number_of_fields_allocated
        if (Fields(ii)%status .eq.  PSMILe_status_defined) then
          if (associated(Fields(ii)%io_chan_infos) ) then
            if(Fields(ii)%io_chan_infos(1)%status.eq.PSMILe_status_defined) then
!RV   At this point a Field is subject to I/O.
              no_of_io_fields=no_of_io_fields+1 
              ivar_ids(no_of_io_fields)=ii
              iglobal_grid_ids(no_of_io_fields)= &
                      Grids(Methods(Fields(ii)%method_id)%grid_id)%global_grid_id
            endif
          endif
        endif
      enddo
       

#ifdef VERBOSE
      print*,trim(ch_id),' : psmile_enddef_metadata:0: ',no_of_io_fields,iglobal_grid_ids(1:no_of_io_fields)
      call psmile_flushstd
#endif

      if(no_of_io_fields.gt.0) then
!
!RV   Sort arrays according to their global_grid_id
!
      allocate(indices(no_of_io_fields),stat=ierror)
      allocate(itemp(no_of_io_fields),stat=ierror)
      allocate(itemp1(Number_of_Grids_allocated),stat=ierror)
      allocate(ino_grids(no_of_io_fields),stat=ierror)

      call indexi(no_of_io_fields,iglobal_grid_ids,indices)

      itemp(1:no_of_io_fields)=iglobal_grid_ids(indices(1:no_of_io_fields))
      iglobal_grid_ids(1:no_of_io_fields)=itemp(1:no_of_io_fields)

      itemp(1:no_of_io_fields)=ivar_ids(indices(1:no_of_io_fields))
      ivar_ids(1:no_of_io_fields)=itemp(1:no_of_io_fields)
!
!RV   Find chunks with identical global_grid_id
!

      ino_of_glob_grids =1
      iid=iglobal_grid_ids(1)
      ino_grids(ino_of_glob_grids)=0
      do ii=1,no_of_io_fields
        if(iid.eq.iglobal_grid_ids(ii)) then
          ino_grids(ino_of_glob_grids)=ino_grids(ino_of_glob_grids)+1
        else
          iid=iglobal_grid_ids(ii)
          ino_of_glob_grids =ino_of_glob_grids +1
          ino_grids(ino_of_glob_grids)=1
        endif
      enddo
#ifdef VERBOSE
      print*,trim(ch_id),' : psmile_enddef_metadata:1:' &
                       ,'ino_of_glob_grids,ino_grids(1:ino_of_glob_grids)' &
                       ,ino_of_glob_grids,ino_grids(1:ino_of_glob_grids)
      call psmile_flushstd
#endif
!
!RV   Build the relationship for var_ids on a certain global grid
!RV   having the same local_name. If several items ocure with the same
!RV   name we have presumably a block structured grid where a certain name
!RV   lives on several blocks! (Please refer to the parallelization
!RV   of the GME grid! The parallelization is done for each logical
!RV   rectangular block rather than distributing blocks over tasks!
!

      iid=1
      do ii=1,ino_of_glob_grids

        call indexi(ino_grids(ii),ivar_ids(iid),indices)
        itemp(1:ino_grids(ii))=ivar_ids(indices(1:ino_grids(ii))+iid-1)
        
        icltn=1
        cl_temp_name=Fields(itemp(icltn))%local_name

        do while(icltn.le.ino_grids(ii))

#ifdef VERBOSE
          print*,trim(ch_id),' : psmile_enddef_metadata:2:' &
                        ,'ii,iid,itemp(1:ino_grids(ii)),trim(cl_temp_name)' &
                        ,ii,iid,itemp(1:ino_grids(ii)),trim(cl_temp_name)
          call psmile_flushstd
#endif
          ino_of_items=0
          do jj=icltn,ino_grids(ii)

            if(trim(cl_temp_name).eq.trim(Fields(itemp(jj))%local_name) .and. &
              jj.lt.ino_grids(ii)) then

              ino_of_items=ino_of_items+1
              itemp1(ino_of_items)=itemp(jj)

            else
              if(trim(cl_temp_name).eq.trim(Fields(itemp(jj))%local_name)) then
                ino_of_items=ino_of_items+1
                itemp1(ino_of_items)=itemp(jj)
              endif

              do kk=1,ino_of_items
!
!             This is an loop over multiple I/O tasks per varid
!
                do il_tskid=1,size(Fields(itemp1(kk))%io_task_lookup)
              
                  ilp=Fields(itemp1(kk))%io_task_lookup(il_tskid)
!
!             Let io_infos point to the real location of the I/O infos
!
                  if(ilp .gt. 0 ) then
                    Fields(itemp1(kk))%io_infos =>  &
                     Fields(itemp1(kk))%io_chan_infos(ilp)
!
                  if(.not.associated(Fields(itemp1(kk))%io_infos%related_ids)) &
                     allocate(Fields(itemp1(kk)) &
                              %io_infos%related_ids(ino_of_items))
!
!RV   The block_id in order to find the data at the correct record
!RV   of the NetCDF file
!
                  Fields(itemp1(kk)) &
                          %io_infos%block_id=kk
!
!RV   The relation ship between var_ids of the same local name.
!
                  Fields(itemp1(kk)) &
                          %io_infos%related_ids(1:ino_of_items) &
                          =itemp1(1:ino_of_items)
!
!RV   opened implements a status register. If one of the entries
!RV   is true a block member of the Field already opened the file.
!
                  Fields(itemp1(kk)) &
                          %io_infos%opened=.false.
!
!RV   If done is all true all data which are  local to a process were 
!RV   assembled in a 3d field and can be written to file. 
!RV   Likewise on read a process reads its pile of blocks and sets
!RV   done of all related var_ids to true.  
!
                  Fields(itemp1(kk)) &
                          %io_infos%done=.false.
#ifdef VERBOSE
                  print*,trim(ch_id),' : psmile_enddef_metadata: <'
                  print*,trim(ch_id),' : varid,local_name,blockid,relation' 
                  print*,trim(ch_id),' : ',itemp1(kk),trim(cl_temp_name) &
                                     ,Fields(itemp1(kk))%io_infos%block_id &
                        ,Fields(itemp1(kk))%io_infos%related_ids(1:ino_of_items)
                  print*,trim(ch_id),' : psmile_enddef_metadata: >'
      
                  call psmile_flushstd

#endif
                endif
                enddo
              enddo
              icltn=icltn+ino_of_items
              ino_of_items=0
              cl_temp_name=Fields(itemp(jj))%local_name
            endif
!
!           Leave the search loop for a next iteration.
!
            if(ino_of_items.eq.0) exit
          enddo
        enddo ! End of Do While
        iid=ino_grids(ii)+1
      enddo

      deallocate(indices,stat=ierror)
      deallocate(itemp,stat=ierror)
      deallocate(itemp1,stat=ierror)
      deallocate(ino_grids,stat=ierror)

      endif
    
      
      
      call psmile_def_domains(ierror)
      call psmile_open_files(ierror)
      call psmile_write_meta(ierror)


      deallocate(ivar_ids,stat=ierror)
      deallocate(iglobal_grid_ids,stat=ierror)
      
#ifdef VERBOSE
      print*,trim(ch_id),' : psmile_enddef_metadata: end'
      call psmile_flushstd
      
#endif      
#endif

      end subroutine PSMILe_Enddef_Metadata