! Method: Loop over tapes and fields per tape setting appropriate variables and!         calling appropriate routines! ! Author: CCM Core Group! !-----------------------------------------------------------------------      use ioFileMod      use time_manager, only: get_curr_date, get_curr_time#if ( defined SPMD )      use mpishorthand#endif!-----------------------------------------------------------------------#include <comctl.h>!-----------------------------------------------------------------------!! Local workspace!      integer :: t, f              ! tape, field indices      integer :: coldimin          ! column dimension of model array      integer :: begver            ! on-node vert start index      integer :: endver            ! on-node vert end index      integer :: begdim3           ! on-node chunk or lat start index      integer :: enddim3           ! on-node chunk or lat end index      type (dim_index_3d) :: dimind  ! 3-D dimension index      integer :: day, sec          ! day and seconds from base date      integer :: i                 ! index!! Get users logname and machine hostname!      if ( masterproc )then         logname = ' '         call getenv ('LOGNAME',logname)         if (logname=='        ') then            write(6,*)'PARSE_NAMELIST: Cannot find LOGNAME environment variable'            call endrun         end if         host = ' '         call getenv ('HOST',host)      end if!! Set default history history contents!      call h_default ()!! Override averaging flag for all fields on a particular tape if namelist input so specifies!      do t=1,ptapes         if (avgflag_pertape(t) /= ' ') then            call h_override (t)         end if      end do!! Define field list information for all history files.  ! Update mtapes to reflect *current* number of history files (note, ! restart and regen runs can have additional auxiliary history files! declared).!      call fldlst ()!! Loop over max. no. of history files permitted  !      call get_curr_time(day, sec)  ! elapased time since reference date      do t=1,mtapes         nfils(t) = 0            ! no. of time samples in hist. file no. t! Time a beginning of current averaging interval.         beg_time(t) = day + sec/86400._r8      end do!! Check that the number of history files declared does not exceed! the maximum allowed.!      if (mtapes > ptapes) then         write(6,*) 'INTHT: Too many history files declared, max=',ptapes         write(6,*)'To increase, change parameter ptapes.'         call endrun      end if!! Initialize history variables!      do t=1,mtapes         do f=1,nflds(t)            coldimin = tape(t)%hlist(f)%field%coldimin            begver   = tape(t)%hlist(f)%field%begver            endver   = tape(t)%hlist(f)%field%endver            begdim3  = tape(t)%hlist(f)%field%begdim3            enddim3  = tape(t)%hlist(f)%field%enddim3            dimind = dim_index_3d (1,coldimin,begver,endver,begdim3,enddim3)            call allocate_hbuf (tape(t)%hlist(f)%hbuf,dimind,tape(t)%hlist(f)%hbuf_prec)            tape(t)%hlist(f)%hbuf = 0._r8            allocate (tape(t)%hlist(f)%nacs(coldimin,begdim3:enddim3))            do i = begdim3, enddim3               tape(t)%hlist(f)%nacs(:coldimin,i) = 0            end do         end do      end do            return   end subroutine intht!#######################################################################   subroutine write_restart_history (nrg, luhrest)      use binary_io      use ioFileMod#ifdef SPMD# if ( defined STAGGERED )      use spmd_dyn, only: npes, compute_gsfactors, comm_y      use pmgrid, only: myid_z, strip3dxzy, strip3dxzyp, strip2d, twod_decomp      use parutilitiesmodule, only: commglobal, pargatherreal, pargatherint, pargatherreal4# else      use spmd_dyn, only: npes, compute_gsfactors# endif      use mpishorthand#endif      use phys_grid, only: gather_chunk_to_field_int      use dycore, only: dycore_is!--------------------------------------------------------------------------------------------------!! Arguments!      integer, intent(in) :: nrg        ! unit number      integer, intent(in) :: luhrest    ! unit number!! Local workspace!      integer t,f                       ! Tape, field indices      integer numlev                    ! number of vertical levels (dimension and loop)      integer ioerr                     ! write error status      integer coldimin                  ! column dimension of model array      character(len=256) :: fname       ! History restart filename#ifdef SPMD      integer :: numsend                ! number of items to be sent      integer :: numrecv(0:npes-1)      ! number of items to be received      integer :: displs(0:npes-1)       ! displacement array      integer :: numowned               ! number of items owned by this MPI task      integer :: mpireal                ! MPI real data type#endif      type (hbuffer_3d) :: hbuf         ! full-field history buffer written by master      integer, pointer :: fullnacs(:,:) ! full-field accumulation counter written by master      type (dim_index_3d) :: dimind     ! 3-D dimension index!!-----------------------------------------------------------------------! Write the history restart data if necessary!-----------------------------------------------------------------------!      where (hstwr(:))         rgnht(:) = .false.      elsewhere         rgnht(:) = .true.      end where      if (masterproc) then         write (nrg) rgnht, mtapes, varid, fincl, fexcl      end if!! If a history tape is not currently being disposed then write a history buffer restart file.! History restart info: some f90 compilers (e.g. SGI) complain about I/O of derived types which ! have pointer components, so explicitly write each one.!      do t=1,mtapes         if (masterproc) then            write (nrg, iostat=ioerr) nhtfrq(t), nflds(t), nfils(t), mfilt(t), &                                      nfpath(t), cpath(t), nhfil(t),  &                                      nhstpr(t), ndens(t), ncprec(t), beg_time(t)            if (ioerr /= 0 ) then               write (6,*) 'WRITE ioerror ',ioerr,' on i/o unit = ',nrg               call endrun            end if            do f=1,nflds(t)               write (nrg,iostat=ioerr) tape(t)%hlist(f)%field%name,        &                                        tape(t)%hlist(f)%field%long_name,   &                                        tape(t)%hlist(f)%field%units,       &                                        tape(t)%hlist(f)%field%numlev,      &                                        tape(t)%hlist(f)%field%decomp_type, &                                        tape(t)%hlist(f)%avgflag,           &                                        tape(t)%hlist(f)%time_op,           &                                        tape(t)%hlist(f)%hbuf_prec,         &                                        tape(t)%hlist(f)%hwrt_prec               if (ioerr /= 0 ) then                  write(6,*)'WRITE_RESTART_HISTORY: End or error condition writing ', &                       'history restart field ',f,' from tape ',t                  call endrun               end if            end do         end if         if (rgnht(t)) then            if (masterproc) then               fname = interpret_filename_spec( rhfilename_spec, number=(t-1) )               hrestpath(t) = trim(get_archivedir('rest'))//fname               write (nrg,iostat=ioerr) hrestpath(t)               if (ioerr /= 0 ) then                  write(6,*)'WRITE_RESTART_HISTORY: End or error condition writing ', &                       'history restart filename to master restart file'                  call endrun               end if               call opnfil (fname, luhrest, 'u')            endif            do f=1,nflds(t)               coldimin =  tape(t)%hlist(f)%field%coldimin               numlev   =  tape(t)%hlist(f)%field%numlev#ifdef SPMD               if (masterproc) then                  dimind = dim_index_3d (1,plon,1,numlev,1,plat)                  call allocate_hbuf (hbuf,dimind,tape(t)%hlist(f)%hbuf_prec)                  allocate (fullnacs(plon,plat))               else                  call assoc_hbuf_with_nothing (hbuf,tape(t)%hlist(f)%hbuf_prec)                  fullnacs => nothing_int               end if               if (tape(t)%hlist(f)%hbuf_prec == 8) then                  mpireal = mpir8               else                  mpireal = mpir4               end if               select case (tape(t)%hlist(f)%field%decomp_type)               case (phys_decomp)                  call gather_chunk_to_field_hbuf (1, numlev, 1, plon, tape(t)%hlist(f)%hbuf, hbuf)                  call gather_chunk_to_field_int (1, 1, 1, plon, tape(t)%hlist(f)%nacs, fullnacs)               case (dyn_decomp)                  if ( dycore_is('LR') )then# if ( defined STAGGERED )! NEW LR CODING                     if (tape(t)%hlist(f)%hbuf_prec == 8) then                        select case (numlev)                        case (1)                           if (myid_z .eq. 0) call pargatherreal(comm_y, 0,  &                                  tape(t)%hlist(f)%hbuf%buf8, strip2d, hbuf%buf8)                        case (plev)                           call pargatherreal(commglobal, 0, tape(t)%hlist(f)%hbuf%buf8, &                                       strip3dxzy, hbuf%buf8)                        case (plevp)                           call pargatherreal(commglobal, 0, tape(t)%hlist(f)%hbuf%buf8, &                                       strip3dxzyp, hbuf%buf8)                        case default                           write(6,*)'WRITE_RESTART_HISTORY: invalid number of levels=', numlev                           call endrun ()                        end select                        if (myid_z .eq. 0) call pargatherint(comm_y, 0, &                           tape(t)%hlist(f)%nacs, strip2d, fullnacs)                     else                        select case (numlev)                        case (1)                           if (myid_z .eq. 0) call pargatherreal4(comm_y, 0,  &                                  tape(t)%hlist(f)%hbuf%buf4, strip2d, hbuf%buf4)                        case (plev)                           call pargatherreal4(commglobal, 0, tape(t)%hlist(f)%hbuf%buf4, &                                       strip3dxzy, hbuf%buf4)                        case (plevp)                           call pargatherreal4(commglobal, 0, tape(t)%hlist(f)%hbuf%buf4, &                                       strip3dxzyp, hbuf%buf4)                        case default                           write(6,*)'WRITE_RESTART_HISTORY: invalid number of levels=', numlev                           call endrun ()                        end select                        if (myid_z .eq. 0) call pargatherint(comm_y, 0, &                           tape(t)%hlist(f)%nacs, strip2d, fullnacs)                     endif# endif                  else                     numowned = coldimin*numlev                     call compute_gsfactors (numowned, numsend, numrecv, displs)                     call mpigatherv_hbuf (tape(t)%hlist(f)%hbuf, numsend, mpireal, hbuf, numrecv, &                                           displs, mpireal, 0, mpicom)                     numowned = coldimin                     call compute_gsfactors (numowned, numsend, numrecv, displs)                     call mpigatherv (tape(t)%hlist(f)%nacs, numsend, mpiint, fullnacs, numrecv, &                                      displs, mpiint, 0, mpicom)                  endif               end select               if (masterproc) then                  call write_hbuf (hbuf, luhrest, ioerr)                  call deallocate_hbuf (hbuf)                  write (luhrest,iostat=ioerr) fullnacs                  deallocate (fullnacs)               else                  call nullify_hbuf (hbuf)                  nullify (fullnacs)               end if#else               select case (tape(t)%hlist(f)%field%decomp_type)               case (phys_decomp)                  dimind = dim_index_3d (1,plon,1,numlev,1,plat)                  call allocate_hbuf (hbuf,dimind,tape(t)%hlist(f)%hbuf_prec)                  call gather_chunk_to_field_hbuf (1, numlev, 1, plon, tape(t)%hlist(f)%hbuf, hbuf)                  call write_hbuf (hbuf, luhrest, ioerr)                  call deallocate_hbuf (hbuf)                  allocate (fullnacs(plon,plat))                  call gather_chunk_to_field_int (1, 1, 1, plon, tape(t)%hlist(f)%nacs, fullnacs)                  write (luhrest,iostat=ioerr) fullnacs                  deallocate (fullnacs)               case (dyn_decomp)                  call write_hbuf (tape(t)%hlist(f)%hbuf, luhrest, ioerr)                  write (luhrest,iostat=ioerr) tape(t)%hlist(f)%nacs               end select#endif            end do            if (masterproc) close (unit=luhrest)         end if      end do      return   end subroutine write_restart_history!#######################################################################   subroutine read_restart_history (nrg, luhrest)      use ppgrid,    only: begchunk, endchunk      use phys_grid, only: get_ncols_p, scatter_field_to_chunk_int      use rgrid,     only: nlon      use dycore,    only: dycore_is      use binary_io      use ioFileMod#ifdef SPMD# if ( defined STAGGERED )      use pmgrid, only: strip3dxzy, strip3dxzyp, strip2d, twod_decomp      use restart_dynamics, only: lrreadin, lrreadini, lrreadin4# endif      use mpishorthand#endif!-----------------------------------------------------------------------#include <comctl.h>!-----------------------------------------------------------------------!