history.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

!#######################################################################

   character(len=nlen) function get_hist_restart_filepath( tape )
!----------------------------------------------------------------------- 
! 
! Purpose: Return full filepath of restart file for given tape number
! This allows public read access to the filenames without making
! the filenames public data.
!
!----------------------------------------------------------------------- 
  integer, intent(in) :: tape  ! Tape number

  get_hist_restart_filepath = hrestpath( tape )
  end function get_hist_restart_filepath

!#######################################################################

  integer function get_mtapes( )
!----------------------------------------------------------------------- 
! 
! Purpose: Return the number of tapes being used.
! This allows public read access to the number of tapes without making
! mtapes public data.
!
!----------------------------------------------------------------------- 
  get_mtapes = mtapes
  end function get_mtapes


!#######################################################################

   subroutine fldlst ()
!----------------------------------------------------------------------- 
! 
! Purpose: Define the contents of each history file based on namelist input for initial or branch
! run, and restart data if a restart run.
!          
! Method: Use arrays fincl and fexcl to modify default history tape contents.
!         Then sort the result alphanumerically for later use by OUTFLD to
!         allow an n log n search time.
! 
! Author: Jim Rosinski
! 
!-----------------------------------------------------------------------
#include <comctl.h>
!---------------------------Local variables-----------------------------
!
      integer t, f                   ! tape, field indices
      integer ff                     ! index into include, exclude and fprec list
      character(len=8) :: name       ! field name portion of fincl (i.e. no avgflag separator)
      character(len=8) :: mastername ! name from masterlist field
      character(len=1) :: avgflag    ! averaging flag
      character(len=1) :: prec_acc   ! history buffer precision flag
      character(len=1) :: prec_wrt   ! history buffer write precision flag

      type (hentry) :: tmp           ! temporary used for swapping
!
! First ensure contents of fincl, fexcl, fhstpr and fwrtpr are all valid names
!
      do t=1,ptapes
         f = 1
         do while (f < pflds .and. fincl(f,t) /= ' ')
            name = getname (fincl(f,t))
            do ff=1,nfmaster
               mastername = masterlist(ff)%field%name
               if (name == mastername) exit
            end do
            if (name /= mastername) then
               write(6,*)'FLDLST: ', trim(name), ' in fincl(', f, ') not found'
               call endrun
            end if
            f = f + 1
         end do

         f = 1
         do while (f < pflds .and. fexcl(f,t) /= ' ')
            do ff=1,nfmaster
               mastername = masterlist(ff)%field%name
               if (fexcl(f,t) == mastername) exit
            end do
            if (fexcl(f,t) /= mastername) then
               write(6,*)'FLDLST: ', fexcl(f,t), ' in fexcl(', f, ') not found'
               call endrun
            end if
            f = f + 1
         end do

         f = 1
         do while (f < pflds .and. fhstpr(f,t) /= ' ')
            name = getname (fhstpr(f,t))
            do ff=1,nfmaster
               mastername = masterlist(ff)%field%name
               if (name == mastername) exit
            end do
            if (name /= mastername) then
               write(6,*)'FLDLST: ', trim(name), ' in fhstpr(', f, ') not found'
               call endrun
            end if
            do ff=1,f-1                 ! If duplicate entry is found, stop
               if (trim(name) == trim(getname(fhstpr(ff,t)))) then
                  write(6,*)'FLDLST: Duplicate field ', name, ' in fhstpr'
                  call endrun
               end if
            end do
            f = f + 1
         end do

         f = 1
         do while (f < pflds .and. fwrtpr(f,t) /= ' ')
            name = getname (fwrtpr(f,t))
            do ff=1,nfmaster
               mastername = masterlist(ff)%field%name
               if (name == mastername) exit
            end do
            if (name /= mastername) then
               write(6,*)'FLDLST: ', trim(name), ' in fwrtpr(', f, ') not found'
               call endrun
            end if
            do ff=1,f-1                 ! If duplicate entry is found, stop
               if (trim(name) == trim(getname(fwrtpr(ff,t)))) then
                  write(6,*)'FLDLST: Duplicate field ', name, ' in fwrtpr'
                  call endrun
               end if
            end do
            f = f + 1
         end do
      end do
!
! If kind values r8 and r4 are identical, set accumulation precision to 8 bytes
!
      if (r4 == r8 .and. any(nhstpr == 4)) then
         nhstpr(:) = 8
         if (masterproc) then
            write(6,*) 'FLDLST: Set nhstpr to 8 because kind values r8 and r4 are identical'
         end if
      end if

      nflds(:) = 0

      do t=1,ptapes
!
! Add the field to the tape if specified via namelist (FINCL[1-ptapes]), or if
! it is on by default and was not excluded via namelist (FEXCL[1-ptapes]).
! Also set history buffer accumulation and output precision values according
! to the values specified via namelist (FHSTPR[1-ptapes] and FWRTPR[1-ptapes])
! or, if not on the list, to the default values given by ndens(t) and
! nhstpr(t), respectively.
!
         do f=1,nfmaster
            mastername = masterlist(f)%field%name
            call list_index (fhstpr(1,t), mastername, ff)
            if (ff > 0) then
               prec_acc = getflag(fhstpr(ff,t))
            else
               prec_acc = ' '
            end if

            call list_index (fwrtpr(1,t), mastername, ff)
            if (ff > 0) then
               prec_wrt = getflag(fwrtpr(ff,t))
            else
               prec_wrt = ' '
            end if

            call list_index (fincl(1,t), mastername, ff)
            if (ff > 0) then
               avgflag = getflag (fincl(ff,t))
               call inifld (t, f, avgflag, prec_acc, prec_wrt)
            else if (.not. empty_htapes) then
               call list_index (fexcl(1,t), mastername, ff)
               if (ff == 0 .and. masterlist(f)%actflag(t)) then
                  call inifld (t, f, ' ', prec_acc, prec_wrt)
               end if
            end if
         end do
!
! Specification of tape contents now complete.  Sort each list of active 
! entries for efficiency in OUTFLD.  Simple bubble sort.
!
         do f=nflds(t)-1,1,-1
            do ff=1,f

               if (tape(t)%hlist(ff)%field%name > tape(t)%hlist(ff+1)%field%name) then
            
                  tmp = tape(t)%hlist(ff)
                  tape(t)%hlist(ff  ) = tape(t)%hlist(ff+1)
                  tape(t)%hlist(ff+1) = tmp

               else if (tape(t)%hlist(ff  )%field%name == tape(t)%hlist(ff+1)%field%name) then
                  
                  write(6,*)'FLDLST: Duplicate field ', tape(t)%hlist(ff  )%field%name
                  write(6,*)'t,ff,name=',t,ff,tape(t)%hlist(ff  )%field%name
                  call endrun
            
               end if

            end do
         end do

         if (masterproc) then
            if (nflds(t) > 0) then
               write(6,*)'FLDLST: Included fields tape ',t,'=',nflds(t)
            end if
   
            do f=1,nflds(t)
               write(6,*) f,' ',tape(t)%hlist(f)%field%name, tape(t)%hlist(f)%field%numlev, &
                            ' ',tape(t)%hlist(f)%avgflag
            end do
         end if
      end do
!
! Determine total number of active history tapes
!
      mtapes = 0
      do t=ptapes,1,-1
         if (nflds(t) > 0) then
            mtapes = t
            exit
         end if
      end do
!
! Ensure there are no "holes" in tape specification, i.e. empty tapes. Enabling
! holes should not be difficult if necessary.
!
      do t=1,mtapes
         if (nflds(t)  ==  0) then
            write(6,*)'FLDLST: Tape ',t,' is empty'
            call endrun
         end if
      end do
      
!
! Packing density, ndens: With netcdf, only 1 (nf_double) and 2 (nf_float)
! are allowed
! Accumulation precision, nhstpr, must be either 8 (real*8) or 4 (real*4)
!
      do t=1,mtapes
         if (ndens(t) == 1) then
            ncprec(t) = nf_double
         else if (ndens(t) == 2) then
            ncprec(t) = nf_float
         else
            write(6,*)'FLDLST: ndens must be 1 or 2'
            call endrun
         end if

         if (nhstpr(t) /= 8 .and. nhstpr(t) /= 4) then
            write(6,*)'FLDLST: nhstpr must be 8 or 4'
            call endrun
         end if
      end do

      if (masterproc) then
         if (nhtfrq(1) == 0) then
            write(6,*)'History File 1 write frequency MONTHLY'
         else
            write(6,*)'History File 1 write frequency ',nhtfrq(1)
         end if
         
         do t=2,mtapes
            write(6,*)'History File ',t,' write frequency ',nhtfrq(t)
         end do

         do t=1,mtapes
            write(6,*)'Accumulation precision history file ', t, '=', nhstpr(t)
            write(6,*)'Packing density history file ', t, '=', ndens(t)
            write(6,*)'Number of time samples per file (MFILT) for history file ',t,' is ',mfilt(t)
         end do
      end if
!
! set flag indicating h-tape contents are now defined (needed by addfld)
!
      htapes_defined = .true.      

      return
   end subroutine fldlst

!#######################################################################

   subroutine inifld (t, f, avgflag, prec_acc, prec_wrt)
!----------------------------------------------------------------------- 
! 
! Purpose: Add a field to the active list for a history tape
! 
! Method: Copy the data from the master field list to the active list for the tape
!         Also: define mapping arrays from (col,chunk) -> (lon,lat)
! 
! Author: CCM Core Group
! 
!-----------------------------------------------------------------------
!
! Arguments
!
      integer, intent(in) :: t            ! history tape index
      integer, intent(in) :: f            ! field index from master field list

      character*1, intent(in) :: avgflag  ! averaging flag
      character*1, intent(in) :: prec_acc ! history buffer precision flag
      character*1, intent(in) :: prec_wrt ! history output precision flag
!
! Local workspace
!
      integer :: n                        ! field index on defined tape
!
! Ensure that it is not to late to add a field to the history tape
!
      if (htapes_defined) then
         write(6,*)'INIFLD: Attempt to add field ',masterlist(f)%field%name,' after history files set'
         call endrun ()
      end if

      nflds(t) = nflds(t) + 1
      n = nflds(t)
!
! Copy field info.
!
      tape(t)%hlist(n)%field = masterlist(f)%field
!
! Set history buffer size and its output data type flags. Set them to
! the default values given by, respective, nhstpr(t) and ndens(t)
! if the input flags prec_acc and prec_wrt are blank; otherwise set to
! the specified values.
!
#ifdef CRAY
      tape(t)%hlist(n)%hbuf_prec = 8
      tape(t)%hlist(n)%hwrt_prec = 8

      if (prec_acc /= ' ' .and. prec_acc /= '8') then
         if (prec_acc == '4') then
            if (masterproc) then
               write(6,*) 'INIFLD: Requested change in history buffer size for ', &
                          tape(t)%hlist(n)%field%name, ' ignored'
            end if
         else
            write(6,*)'INIFLD: unknown prec_acc=',prec_acc
            call endrun
         end if
      end if

      if (prec_wrt /= ' ' .and. prec_wrt /= '8') then
         if (prec_wrt == '4') then