!*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !---------- !ug support !>Write out metadata and data for axes and fields to a restart file !!associated with an unstructured mpp domain. subroutine fms_io_unstructured_save_restart(fileObj, & time_stamp, & directory, & append, & time_level) !Inputs/Outputs type(restart_file_type),intent(inout),target :: fileObj != 0.0 ! The value of time_level is written as a new value of the time axis data. !If time_level is present and time_level < 0.0: ! A new file is opened and only the meta data is written. !If append is present and append=.false.: ! Behaves the same was as if it were not present. That is, meta data is ! written and whether or not field data is written is determined by time_level. !Local variables type(domainUG),pointer :: domain ! null() do j = 1,size(fileObj%axes) if (j .eq. CIDX .or. j .eq. HIDX .or. j .eq. UIDX) then if (allocated(fileObj%axes(j)%idx)) then if (.not. associated(fileObj%axes(j)%domain_ug)) then call mpp_error(FATAL, & "fms_io_unstructured_save_restart:" & //" the axis "//trim(fileObj%axes(j)%name) & //" in the file "//trim(fileObj%name) & //" was not registered with an unstructured" & //" mpp domain.") endif if (associated(domain)) then if (.not. (domain .EQ. fileObj%axes(j)%domain_ug)) then call mpp_error(FATAL, & "fms_io_unstructured_save_restart:" & //" two axes registered to same" & //" restart file are associated with" & //" different unstructured mpp domains.") endif else domain => fileObj%axes(j)%domain_ug endif endif else if (associated(fileObj%axes(j)%data)) then if (.not. associated(fileObj%axes(j)%domain_ug)) then call mpp_error(FATAL, & "fms_io_unstructured_save_restart:" & //" the axis "//trim(fileObj%axes(j)%name) & //" in the file "//trim(fileObj%name) & //" was not registered with an unstructured" & //" mpp domain.") endif if (associated(domain)) then if (.not. (domain .EQ. fileObj%axes(j)%domain_ug)) then call mpp_error(FATAL, & "fms_io_unstructured_save_restart:" & //" two axes registered to same" & //" restart file are associated with" & //" different unstructured mpp domains.") endif else domain => fileObj%axes(j)%domain_ug endif endif endif enddo !Make sure that all registered fields are associated with the same !unstructured domain that all axes were registered with. do j = 1,fileObj%nvar if (.not. associated(fileObj%var(j)%domain_ug)) then call mpp_error(FATAL, & "fms_io_unstructured_save_restart:" & //" the field "//trim(fileObj%var(j)%name) & //" in the file "//trim(fileObj%name) & //" was not registered with an unstructured" & //" mpp domain.") endif if (.not. (domain .EQ. fileObj%var(j)%domain_ug)) then call mpp_error(FATAL, & "fms_io_unstructured_save_restart:" & //" the unstructured domain associated with" & //" field "//trim(fileObj%var(j)%name) & //" in the file "//trim(fileObj%name) & //" does not match the unstructured domain" & //" associated with the registered axes.") endif enddo !If necessary, make sure a valid set of optional arguments was provided. if (present(append)) then if (append .and. .not. present(time_level)) then call mpp_error(FATAL, & "fms_io_unstructured_save_compressed_restart:" & //" a time_level must be present when" & //" append=.true. for file "//trim(fileObj%name)) endif endif !Determine whether or not metadata will be written to the restart file. If !no optional arguments are specified, metadata will be written to the file, !with any old data overwritten. If the optional append flag is true, then !it is assumed that the metadata already exists in the file, and thus !metadata will not be written to the file. mpp_action = MPP_OVERWR write_meta_data = .true. if (present(append)) then if (append) then mpp_action = MPP_APPEND write_meta_data = .false. if (time_level .lt. 0.0) then call mpp_error(FATAL, & "fms_io_unstructured_save_restart:" & //" the inputted time_level cannot be" & //" negative when append is .true." & //" for file "//trim(fileObj%name)) endif endif endif !Determine whether or not field data will be written to the restart file. !Field data will be written to the restart file unless a negative !time_level value is passed in. write_field_data = .true. if (present(time_level)) then if (time_level .lt. 0) then write_field_data = .false. endif endif !Set the directory where the restart file lives. This defaults to !"./RESTART". dir = "RESTART" if (present(directory)) then dir = trim(directory) endif !Set the name of the restart file excluding its path. !time_stamp_restart is a module variable. restartname = trim(fileObj%name) if (time_stamp_restart) then if (present(time_stamp)) then if (len_trim(restartname) + len_trim(time_stamp) .gt. 79) then call mpp_error(FATAL, & "fms_io_unstructured_save_restart:" & //" length of restart file name including" & //" time stamp is greater than allowed" & //" restart file name length.") endif restartname = trim(time_stamp)//"."//trim(restartname) endif endif !Set the name of the restart file including the path to it. if (len_trim(dir) .gt. 0) then restartpath = trim(dir)//"/"//trim(restartname) else restartpath = trim(restartname) endif !Open the restart file. call mpp_open(funit, & trim(restartpath), & action=mpp_action, & form=form, & is_root_pe=fileObj%is_root_pe, & domain_ug=domain) !Write out the metadata for the axes and fields. axis => null() cur_var => null() if (write_meta_data) then !If it is registered, then write out the metadata for the x-axis !to the restart file. if (associated(fileObj%axes(XIDX)%data)) then axis => fileObj%axes(XIDX) call mpp_write_meta(funit, & x_axis, & axis%name, & axis%units, & axis%longname, & data=axis%data, & cartesian="X") axis => null() x_axis_defined = .true. else x_axis_defined = .false. endif !If it is registered, then write out the metadata for the y-axis !to the restart file. if (associated(fileObj%axes(YIDX)%data)) then axis => fileObj%axes(YIDX) call mpp_write_meta(funit, & y_axis, & axis%name, & axis%units, & axis%longname, & data=axis%data, & cartesian="Y") axis => null() y_axis_defined = .true. else y_axis_defined = .false. endif !If it is registered, then write out the metadata for the z-axis !to the restart file. if (associated(fileObj%axes(ZIDX)%data)) then axis => fileObj%axes(ZIDX) call mpp_write_meta(funit, & z_axis, & axis%name, & axis%units, & axis%longname, & data=axis%data, & cartesian="Z") axis => null() z_axis_defined = .true. else z_axis_defined = .false. endif !If it is registered, then write out the metadata for the cc-axis (???) !to the restart file. if (associated(fileObj%axes(CCIDX)%data)) then axis => fileObj%axes(CCIDX) call mpp_write_meta(funit, & cc_axis, & axis%name, & axis%units, & axis%longname, & data=axis%data, & cartesian="CC") axis => null() cc_axis_defined = .true. else cc_axis_defined = .false. endif !If it is registered, then write out the metadata for the compressed !c-axis to the restart file. if (allocated(fileObj%axes(CIDX)%idx)) then axis => fileObj%axes(CIDX) call mpp_def_dim(funit, & trim(axis%dimlen_name), & axis%dimlen, & trim(axis%dimlen_lname), & (/(i,i=1,axis%dimlen)/)) call mpp_write_meta(funit, & c_axis, & axis%name, & axis%units, & axis%longname, & data=axis%idx, & compressed=axis%compressed, & min=axis%imin) axis => null() c_axis_defined = .true. else c_axis_defined = .false. endif !If it is registered, then write out the metadata for the compressed !h-axis to the restart file. if (allocated(fileObj%axes(HIDX)%idx)) then axis => fileObj%axes(HIDX) call mpp_def_dim(funit, & trim(axis%dimlen_name), & axis%dimlen, & trim(axis%dimlen_lname), & (/(i,i=1,axis%dimlen)/)) call mpp_write_meta(funit, & h_axis, & axis%name, & axis%units, & axis%longname, & data=axis%idx, & compressed=axis%compressed, & min=axis%imin) axis => null() h_axis_defined = .true. else h_axis_defined = .false. endif !Write out the time axis to the restart file. if (associated(fileObj%axes(TIDX)%data)) then axis => fileObj%axes(TIDX) call mpp_write_meta(funit, & t_axis, & axis%name, & units=axis%units, & longname=axis%longname, & cartesian="T", & calendar=axis%calendar) axis => null() else call mpp_write_meta(funit, & t_axis, & "Time", & "time level", & "Time", & cartesian="T") endif !Loop through the fields and write out the metadata. do j = 1,fileObj%nvar !Point to the current field. cur_var => fileObj%var(j) !Cycle to the next field if the current field is read only. if (cur_var%read_only) then cur_var => null() cycle endif !Make sure the field has a valid number of time levels. if (cur_var%siz(4) .gt. 1 .and. cur_var%siz(4) .ne. & fileObj%max_ntime) then call mpp_error(FATAL, & "fms_io_unstructured_save_restart: " & //trim(cur_var%name)//" in file " & //trim(fileObj%name)//" has more than one" & //" time level, but the number of time levels" & //" is not equal to max_ntime.") endif !Determine the dimensions for the field. For a scalar field foo, !it is assumed that foo = foo(t). For non-scalar fields, time !maybe added as the last dimension. if (cur_var%ndim .eq. 0) then num_var_axes = 1 var_axes(1) = t_axis else num_var_axes = cur_var%ndim do k = 1,cur_var%ndim select case (cur_var%field_dimension_order(k)) case (XIDX) var_axes(k) = x_axis case (YIDX) var_axes(k) = y_axis case (ZIDX) var_axes(k) = z_axis case (CCIDX) var_axes(k) = cc_axis case (CIDX) var_axes(k) = c_axis case (HIDX) var_axes(k) = h_axis case default call mpp_error(FATAL, & "fms_io_unstructured_save_restart:" & //" unsupported dimension type for" & //" field "//trim(cur_var%name) & //" in file "//trim(fileObj%name)) end select enddo if (cur_var%siz(4) .eq. fileObj%max_ntime) then num_var_axes = num_var_axes + 1 var_axes(num_var_axes) = t_axis endif endif !Get the "pack size" for default real types, where !pack_size = (Number of bits in a real(8))/(Number of bits in a real). cpack = pack_size !For each time level, calculate a check-sum of the field data. !Fields with integer(4) data are handled differently then real !fields. To signify an integer(4) field, set cpack = 0. allocate(check_val(max(1,cur_var%siz(4)))) do k = 1,cur_var%siz(4) if (associated(fileObj%p0dr(k,j)%p)) then check_val(k) = mpp_chksum(fileObj%p0dr(k,j)%p, & (/mpp_pe()/), & mask_val=cur_var%default_data) elseif (associated(fileObj%p1dr(k,j)%p)) then check_val(k) = mpp_chksum(fileObj%p1dr(k,j)%p, & mask_val=cur_var%default_data) elseif (associated(fileObj%p2dr(k,j)%p)) then check_val(k) = mpp_chksum(fileObj%p2dr(k,j)%p, & mask_val=cur_var%default_data) elseif (associated(fileObj%p3dr(k,j)%p)) then check_val(k) = mpp_chksum(fileObj%p3dr(k,j)%p, & mask_val=cur_var%default_data) elseif (associated(fileObj%p0di(k,j)%p)) then check_val(k) = int(fileObj%p0di(k,j)%p,kind=LONG_KIND) cpack = 0 elseif (associated(fileObj%p1di(k,j)%p)) then check_val(k) = mpp_chksum(fileObj%p1di(k,j)%p, & mask_val=cur_var%default_data) cpack = 0 elseif (associated(fileObj%p2di(k,j)%p)) then check_val(k) = mpp_chksum(fileObj%p2di(k,j)%p, & mask_val=cur_var%default_data) cpack = 0 elseif (associated(fileObj%p3di(k,j)%p)) then call mpp_error(FATAL, & "fms_io_unstructured_save_restart:" & //" 3D integer restart fields are not" & //" currently supported. (" & //trim(cur_var%name)//" of file " & //trim(fileObj%name)//")") else call mpp_error(FATAL, & "fms_io_unstructured_save_restart:" & //" there is no pointer associated with " & //" the data of field " & //trim(cur_var%name)//" of file " & //trim(fileObj%name)) endif enddo !Write out the metadata from a field. Check-sums are only written !if field data is written to the restart file. if (write_field_data) then ! Write checksums only if valid field data exists call mpp_write_meta(funit, & cur_var%field, & var_axes(1:num_var_axes), & cur_var%name, & cur_var%units, & cur_var%longname, & pack=cpack, & checksum=check_val, & fill=cur_var%default_data) else call mpp_write_meta(funit, & cur_var%field, & var_axes(1:num_var_axes), & cur_var%name, & cur_var%units, & cur_var%longname, & pack=cpack, & fill=cur_var%default_data) endif deallocate(check_val) cur_var => null() enddo !Write the axis data to the restart file. if (x_axis_defined) then call mpp_write(funit, & x_axis) endif if (y_axis_defined) then call mpp_write(funit, & y_axis) endif if (c_axis_defined) then call mpp_write(funit, & c_axis) endif if (h_axis_defined) then call mpp_write(funit, & h_axis) endif if (cc_axis_defined) then call mpp_write(funit, & cc_axis) endif if (z_axis_defined) then call mpp_write(funit, & z_axis) endif endif !Write out field data to the restart file. if (write_field_data) then !Loop through all time levels. do k = 1,fileObj%max_ntime !Get the time value for the time level. if (present(time_level)) then tlev = time_level else tlev = real(k) endif !Loop through the fields. do j = 1,fileObj%nvar !Point to the current field. cur_var => fileObj%var(j) !Cycle to the next field if the current field is read only. if (cur_var%read_only) then cur_var => null() cycle endif !Write out the field data to the file. if (k .le. cur_var%siz(4)) then if (associated(fileObj%p0dr(k,j)%p)) then call mpp_write(funit, & cur_var%field, & fileObj%p0dr(k,j)%p, & tlev) elseif (associated(fileObj%p1dr(k,j)%p)) then call mpp_io_unstructured_write(funit, & cur_var%field, & domain, & fileObj%p1dr(k,j)%p, & fileObj%axes(cur_var%field_dimension_order(1))%nelems, & tstamp=tlev, & default_data=cur_var%default_data) elseif (associated(fileObj%p2dr(k,j)%p)) then call mpp_io_unstructured_write(funit, & cur_var%field, & domain, & fileObj%p2dr(k,j)%p, & fileObj%axes(cur_var%field_dimension_order(1))%nelems, & tstamp=tlev, & default_data=cur_var%default_data) elseif (associated(fileObj%p3dr(k,j)%p)) then call mpp_io_unstructured_write(funit, & cur_var%field, & domain, & fileObj%p3dr(k,j)%p, & fileObj%axes(cur_var%field_dimension_order(1))%nelems, & tstamp=tlev, & default_data=cur_var%default_data) elseif (associated(fileObj%p0di(k,j)%p)) then r0d = real(fileObj%p0di(k,j)%p) call mpp_write(funit, & cur_var%field, & r0d, & tlev) elseif (associated(fileObj%p1di(k,j)%p)) then allocate(r1d(size(fileObj%p1di(k,j)%p,1))) r1d = real(fileObj%p1di(k,j)%p) call mpp_io_unstructured_write(funit, & cur_var%field, & domain, & r1d, & fileObj%axes(cur_var%field_dimension_order(1))%nelems, & tstamp=tlev, & default_data=cur_var%default_data) deallocate(r1d) elseif (associated(fileObj%p2di(k,j)%p)) then allocate(r2d(size(fileObj%p2di(k,j)%p,1),size(fileObj%p2di(k,j)%p,2))) r2d = real(fileObj%p2di(k,j)%p) call mpp_io_unstructured_write(funit, & cur_var%field, & domain, & r2d, & fileObj%axes(cur_var%field_dimension_order(1))%nelems, & tstamp=tlev, & default_data=cur_var%default_data) deallocate(r2d) else call mpp_error(FATAL, & "fms_io_unstructured_save_restart:" & //" there is no pointer associated" & //" with the data of field " & //trim(cur_var%name)//" of file " & //trim(fileObj%name)) endif endif cur_var => null() enddo enddo endif !Close the restart file. call mpp_close(funit) !Nullify local pointers. domain => null() axis => null() cur_var => null() return end subroutine fms_io_unstructured_save_restart !----------