history.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

            if (masterproc) then
               write(6,*) 'INIFLD: Requested change in history output size for ', &
                          tape(t)%hlist(n)%field%name, ' ignored'
            end if
         else
            write(6,*)'INIFLD: unknown prec_wrt=',prec_wrt
            call endrun
         end if
      end if
#else
      select case (prec_acc)
      case (' ')
         tape(t)%hlist(n)%hbuf_prec = nhstpr(t)
      case ('4')
         if (r4 /= r8) then
            tape(t)%hlist(n)%hbuf_prec = 4
            if (masterproc) then
               write(6,*) 'INIFLD: History buffer for ', tape(t)%hlist(n)%field%name, &
                          ' is real*4'
            end if
         else       ! if kind values r4 and r8 are identical, ignore the request
            tape(t)%hlist(n)%hbuf_prec = 8
            if (masterproc) then
               write(6,*) 'INIFLD: Requested change in history output size for ', &
                           tape(t)%hlist(n)%field%name, ' ignored'
               write(6,*) '        because kind values r8 and r4 are identical'
            end if
         end if
      case ('8')
         tape(t)%hlist(n)%hbuf_prec = 8
         if (masterproc) then
            write(6,*) 'INIFLD: History buffer for ', tape(t)%hlist(n)%field%name, &
                       ' is real*8'
         end if
      case default
         write(6,*)'INIFLD: unknown prec_acc=',prec_acc
         call endrun
      end select

      select case (prec_wrt)
      case (' ')
         if (ndens(t) == 1) then
            tape(t)%hlist(n)%hwrt_prec = 8
         else
            tape(t)%hlist(n)%hwrt_prec = 4
         end if
      case ('4')
         tape(t)%hlist(n)%hwrt_prec = 4
         if (masterproc) then
            write(6,*) 'INIFLD: Output data type for ', tape(t)%hlist(n)%field%name, &
                       ' is real*4'
         end if
      case ('8')
         tape(t)%hlist(n)%hwrt_prec = 8
         if (masterproc) then
            write(6,*) 'INIFLD: Output data type for ', tape(t)%hlist(n)%field%name, &
                       ' is real*8'
         end if
      case default
         write(6,*)'INIFLD: unknown prec_wrt=',prec_wrt
         call endrun
      end select
#endif
!
! Override the default averaging (masterlist) averaging flag if non-blank
!
      if (avgflag == ' ') then
         tape(t)%hlist(n)%avgflag = masterlist(f)%avgflag(t)
         tape(t)%hlist(n)%time_op = masterlist(f)%time_op(t)
      else
         tape(t)%hlist(n)%avgflag = avgflag
         select case (avgflag)
         case ('A')
            tape(t)%hlist(n)%time_op = 'mean'
         case ('I')
            tape(t)%hlist(n)%time_op = ' '
         case ('X')
            tape(t)%hlist(n)%time_op = 'maximum'
         case ('M')
            tape(t)%hlist(n)%time_op = 'minimum'
         case default
            write(6,*)'INIFLD: unknown avgflag=', avgflag
            call endrun
         end select
      end if

#ifdef DEBUG
      write(6,*)'INIFLD: field ', tape(t)%hlist(n)%field%name, ' added as ', 'field number ', n,' on tape ', t
      write(6,*)'units=',tape(t)%hlist(n)%field%units
      write(6,*)'numlev=',tape(t)%hlist(n)%field%numlev
      write(6,*)'avgflag=',tape(t)%hlist(n)%avgflag
      write(6,*)'time_op=',tape(t)%hlist(n)%time_op
      write(6,*)'hbuf_prec=',tape(t)%hlist(n)%hbuf_prec
      write(6,*)'hwrt_prec=',tape(t)%hlist(n)%hwrt_prec
#endif

      return
   end subroutine inifld

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

   character(len=8) function getname (inname)
!----------------------------------------------------------------------- 
! 
! Purpose: retrieve name portion of inname
!          
! Method:  If an averaging flag separater character is present (":") in inname, 
!          lop it off
! 
! Author: Jim Rosinski
! 
!-------------------------------------------------------------------------------
!
! Arguments
!
      character(len=*) inname
!
! Local workspace
!
      integer :: length
      integer :: i
   
      length = len (inname)
      
      if (length < 8 .or. length > 10) then
         write(6,*) 'getname: bad length=',length
         call endrun
      end if
   
      getname = ' '
      do i=1,8
         if (inname(i:i) == ':') exit
         getname(i:i) = inname(i:i)
      end do
      
      return
   end function getname

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

   character(len=1) function getflag (inname)
!----------------------------------------------------------------------- 
! 
! Purpose: retrieve flag portion of inname
!          
! Method:  If an averaging flag separater character is present (":") in inname, 
!          return the character after it as the flag
! 
! Author: Jim Rosinski
! 
!-------------------------------------------------------------------------------
!
! Arguments
!
      character(len=*) inname   ! character string
!
! Local workspace
!
      integer :: length         ! length of inname
      integer :: i              ! loop index

      length = len (inname)

      if (length /= 10) then
         write(6,*) 'getflag: bad length=',length
         call endrun
      end if

      getflag = ' '
      do i=1,9
         if (inname(i:i) == ':') then
            getflag = inname(i+1:i+1)
            exit
         end if
      end do

      return
   end function getflag

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

   subroutine list_index (list, name, index)
!
! Input arguments
!
      character(len=*) :: list(pflds) ! input list of names, possibly ":" delimited
      character(len=8) :: name        ! name to be searched for
!
! Output arguments
!
      integer :: index                ! index of "name" in "list"
!
! Local workspace
!
      character(len=8) :: listname    ! input name with ":" stripped off.
      integer f                       ! field index

      index = 0
      do f=1,pflds
!
! Only list items
!
         listname = getname (list(f))
         if (listname == ' ') exit
         if (listname == name) then
            index = f
            exit
         end if
      end do
      
      return
   end subroutine list_index

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

   subroutine outfld (fname, field, idim, c)
!----------------------------------------------------------------------- 
! 
! Purpose: Accumulate (or take min, max, etc. as appropriate) input field
!          into its history buffer for appropriate tapes
! 
! Method: Search for fname among fields on history tapes.  If found, do the
!         accumulation.  If not found, return silently.
! 
! Author: CCM Core Group
! 
!-----------------------------------------------------------------------
!
! Arguments
!
      character(len=*), intent(in) :: fname ! Field name--should be 8 chars long

      integer, intent(in) :: idim           ! Longitude dimension of field array
      integer, intent(in) :: c              ! chunk (physics) or latitude (dynamics) index

      real(r8), intent(in) :: field(idim,*) ! Array containing field values
!
! Local variables
!
      integer :: t, f                ! tape, field indices
      integer coldimin               ! column dimension of model array
      integer :: fl, fu              ! upper, lower indices used in binary search thru sorted list
      integer :: begver              ! on-node vert start index
      integer :: endver              ! on-node vert end index
      integer :: lexdiff             ! lexical difference (analagous to output from strcmp in C)
      integer :: endi                ! ending longitude index (reduced grid)

      character*8 :: fname8          ! 8-char equivalent of fname
      character*1 :: avgflag         ! averaging flag

      type (hbuffer_2d) :: hbuf      ! history buffer
      integer, pointer :: nacs(:)    ! accumulation counter
      type (dim_index_2d) :: dimind  ! 2-D dimension index
!-----------------------------------------------------------------------

      fname8 = fname
!
! Note, the field may be on any or all of the history files (primary
! and auxiliary).
!
!      write(6,*)'fname8=',fname8
      do 40 t=1,mtapes
!
! Search the sorted list of fields.  Algorithm taken from Numerical
! Recipes in C
!
         fl = 0
         fu = nflds(t) + 1
         
         lexdiff = -1
         do while (fu - fl .gt. 1)
            f = (fl + fu)/2
            lexdiff = strcmpf (fname8, tape(t)%hlist(f)%field%name)
            if (lexdiff < 0) then
               fu = f
            else if (lexdiff > 0) then
               fl = f
            else
               exit
            end if
         end do
         
         if (lexdiff /= 0) then
!          write(6,*)'OUTFLD: field ',fname,' not found on tape ', t
            goto 40
         end if
!
! Field name found.  Update history buffer
!
         begver  = tape(t)%hlist(f)%field%begver
         endver  = tape(t)%hlist(f)%field%endver
         endi    = tape(t)%hlist(f)%field%colperdim3(c)
         avgflag = tape(t)%hlist(f)%avgflag
         coldimin= tape(t)%hlist(f)%field%coldimin
         nacs   => tape(t)%hlist(f)%nacs(:coldimin,c)
         call assoc_hbuf2d_with_hbuf3d (hbuf, tape(t)%hlist(f)%hbuf, c)
         
         dimind = dim_index_2d (1,endi,begver,endver)

         select case (avgflag)

         case ('I') ! Instantaneous

            call hbuf_accum_inst (hbuf, field, nacs, dimind, idim)

         case ('A') ! Time average

            call hbuf_accum_add (hbuf, field, nacs, dimind, idim)

         case ('X') ! Maximum over time

            call hbuf_accum_max (hbuf, field, nacs, dimind, idim)

         case ('M') ! Minimum over time

            call hbuf_accum_min (hbuf, field, nacs, dimind, idim)

         case default

            write(6,*)'OUTFLD: invalid avgflag=', avgflag
            call endrun ()

         end select
40    continue

      return
   end subroutine outfld

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

   integer function strcmpf (name1, name2)
!----------------------------------------------------------------------- 
! 
! Purpose: Return the lexical difference between two strings
! 
! Method: Use ichar() intrinsic as we loop through the names
! 
! Author: Jim Rosinski
! 
!------------------------------------------------------------