LCOV - code coverage report
Current view: top level - physics/clubb/src/CLUBB_core - output_grads.F90 (source / functions) Hit Total Coverage
Test: coverage.info Lines: 0 127 0.0 %
Date: 2024-12-17 17:57:11 Functions: 0 4 0.0 %

          Line data    Source code
       1             : !-------------------------------------------------------------------------------
       2             : ! $Id$
       3             : !===============================================================================
       4             : module output_grads
       5             : 
       6             : 
       7             : ! Description:
       8             : !   This module contains structure and subroutine definitions to
       9             : !   create GrADS output data files for one dimensional arrays.
      10             : !
      11             : !   The structure type (stat_file) contains all necessay information
      12             : !   to generate a GrADS file and a list of variables to be output
      13             : !   in the data file.
      14             : !
      15             : ! References:
      16             : !   None
      17             : !
      18             : ! Original Author:
      19             : !   Chris Golaz, updated 2/18/2003
      20             : !-------------------------------------------------------------------------------
      21             : 
      22             :   use clubb_precision, only: &
      23             :     core_rknd ! Variable(s)
      24             : 
      25             :   implicit none
      26             : 
      27             :   public  :: open_grads, write_grads
      28             : 
      29             :   private :: format_date, check_grads, &
      30             :     determine_time_inc
      31             : 
      32             :   ! Undefined value
      33             :   real( kind = core_rknd ), private, parameter :: undef = -9.99e33_core_rknd
      34             : 
      35             :   private ! Default scope
      36             : 
      37             :   contains
      38             : 
      39             : !-------------------------------------------------------------------------------
      40           0 :   subroutine open_grads( iunit, fdir, fname,  & 
      41           0 :                          ia, iz, nlat, nlon, z, & 
      42           0 :                          day, month, year, lat_vals, lon_vals, & 
      43             :                          time, & 
      44             :                          stats_metadata, nvar, &
      45             :                          grads_file )
      46             : ! Description:
      47             : !   Opens and initialize variable components for derived type 'grads_file'
      48             : !   If the GrADS file already exists, open_grads will overwrite it.
      49             : 
      50             : ! References:
      51             : !   None
      52             : !-------------------------------------------------------------------------------
      53             :     use constants_clubb, only:  & 
      54             :         fstderr,  & ! Constant(s)
      55             :         sec_per_min
      56             : 
      57             :     use stat_file_module, only: & 
      58             :         stat_file ! Type
      59             : 
      60             :     use clubb_precision, only:  & 
      61             :         time_precision ! Variable
      62             : 
      63             :     use stats_variables, only: &
      64             :         stats_metadata_type
      65             : 
      66             :     implicit none
      67             : 
      68             :     ! Input Variables
      69             : 
      70             :     integer, intent(in) :: iunit   ! File unit being written to            [-]
      71             : 
      72             :     character(len=*), intent(in) ::  & 
      73             :       fdir,  & ! Directory where file is stored        [-]
      74             :       fname    ! Name of file                          [-]
      75             : 
      76             :     integer, intent(in) :: & 
      77             :       ia,   & ! Lower Bound of z (altitude)                     [-]
      78             :       iz,   & ! Upper Bound of z (altitude)                     [-]
      79             :       nlat, & ! Number of points in the y direction (latitude)  [-]
      80             :       nlon    ! Number of points in the x direction (longitude) [-]
      81             : 
      82             :     real( kind = core_rknd ), dimension(:), intent(in) :: &
      83             :       z ! Vertical levels       [m]
      84             : 
      85             :     integer, intent(in) ::  & 
      86             :       day,           & ! Day of Month at Model Start    [dd]
      87             :       month,         & ! Month of Year at Model start   [mm]
      88             :       year             ! Year at Model Start            [yyyy]
      89             : 
      90             :     real( kind = core_rknd ), dimension(nlat), intent(in) :: &
      91             :       lat_vals ! Latitude [Degrees E]
      92             : 
      93             :     real( kind = core_rknd ), dimension(nlon), intent(in) :: &
      94             :       lon_vals ! Longitude [Degrees N]
      95             : 
      96             :     real( kind = time_precision ), intent(in) ::  & 
      97             :       time        ! Time since Model start          [s]
      98             : 
      99             :     type (stats_metadata_type), intent(in) :: &
     100             :       stats_metadata
     101             : 
     102             :     ! Number of GrADS variables to store            [#]
     103             :     integer, intent(in) :: nvar
     104             : 
     105             :     ! Input/Output Variables
     106             :     type (stat_file), intent(inout) :: &
     107             :       grads_file ! File data [-]
     108             : 
     109             :     ! Local Variables
     110             : 
     111             :     integer :: k
     112             :     logical :: l_ctl, l_dat, l_error
     113             : 
     114             :     ! ---- Begin Code ----
     115             : 
     116             :     ! Define parameters for the GrADS ctl and dat files
     117             : 
     118           0 :     grads_file%iounit = iunit
     119           0 :     grads_file%fdir   = fdir
     120           0 :     grads_file%fname  = fname
     121           0 :     grads_file%ia     = ia
     122           0 :     grads_file%iz     = iz
     123             : 
     124             :     ! Determine if the altitudes are ascending or descending and setup the
     125             :     ! variable z accordingly.
     126           0 :     if ( ia <= iz ) then
     127           0 :       do k=1,iz-ia+1
     128           0 :         grads_file%z(k) = z(ia+k-1)
     129             :       end do
     130             :     else
     131           0 :       do k=1,ia-iz+1
     132           0 :         grads_file%z(k) = z(ia-k+1)
     133             :       end do
     134             :     end if
     135             : 
     136           0 :     grads_file%day   = day
     137           0 :     grads_file%month = month
     138           0 :     grads_file%year  = year
     139             : 
     140           0 :     grads_file%nlat  = nlat
     141           0 :     grads_file%nlon  = nlon
     142             : 
     143           0 :     allocate( grads_file%lat_vals(nlat), grads_file%lon_vals(nlon) )
     144             : 
     145           0 :     grads_file%lat_vals  = lat_vals
     146           0 :     grads_file%lon_vals  = lon_vals
     147             : 
     148           0 :     grads_file%dtwrite = stats_metadata%stats_tout
     149             : 
     150           0 :     grads_file%nvar = nvar
     151             : 
     152             :     ! Check to make sure the timestep is appropriate. GrADS does not support an
     153             :     ! output timestep less than 1 minute.
     154           0 :     if ( stats_metadata%stats_tout < sec_per_min ) then
     155             :       write(fstderr,*) "Warning: GrADS requires an output timestep of at least &
     156             :                        &one minute, but the requested output timestep &
     157           0 :                        &(stats_tout) is less than one minute."
     158           0 :       if (.not. stats_metadata%l_allow_small_stats_tout) then
     159             :         write(fstderr,*) "To override this warning, set l_allow_small_stats_tout = &
     160             :                          &.true. in the stats_setting namelist in the &
     161           0 :                          &appropriate *_model.in file."
     162           0 :         error stop "Fatal error in open_grads"
     163             :       end if
     164             :     end if
     165             : 
     166             :     ! Check whether GrADS files already exists
     167             : 
     168             :     ! We don't use this feature for the single-column model.  The
     169             :     ! clubb_standalone program will simply overwrite existing data files if they
     170             :     ! exist.  The restart function will create a new GrADS file starting from
     171             :     ! the restart time in the output directory.
     172             : 
     173             :     ! inquire( file=trim(fdir)//trim(fname)//'.ctl', exist=l_ctl )
     174             :     ! inquire( file=trim(fdir)//trim(fname)//'.dat', exist=l_dat )
     175             : 
     176           0 :     l_ctl = .false.
     177           0 :     l_dat = .false.
     178             : 
     179             :     ! If none of the files exist, set ntimes and nrecord and
     180             :     ! to initial values and return
     181             : 
     182             :     if ( .not.l_ctl .and. .not.l_dat ) then
     183             : 
     184           0 :       grads_file%time = time
     185           0 :       grads_file%ntimes = 0
     186           0 :       grads_file%nrecord = 1
     187             :       return
     188             : 
     189             :       ! If both files exists, attempt to append to existing files
     190             : 
     191             :     else if ( l_ctl .and. l_dat ) then
     192             : 
     193             :       !  Check existing ctl file
     194             : 
     195             :       call check_grads( iunit, fdir, fname,  & ! intent(in)
     196             :                         ia, iz, &  ! intent(in)
     197             :                         day, month, year, time, stats_metadata%stats_tout, & ! intent(in) 
     198             :                         nvar,  &  ! intent(in)
     199             :                         l_error, grads_file%ntimes, grads_file%nrecord, & ! intent(out)
     200             :                         grads_file%time ) ! intnet(out)
     201             : 
     202             :       if ( l_error ) then
     203             :         write(unit=fstderr,fmt=*) "Error in open_grads:"
     204             :         write(unit=fstderr,fmt=*)  & 
     205             :         "Attempt to append to existing files failed"
     206             : !              call stopcode('open_grads')
     207             :         error stop 'open_grads'
     208             :       end if
     209             : 
     210             :       return
     211             : 
     212             : !         If one file exists, but not the other, give up
     213             : 
     214             :     else
     215             :       write(unit=fstderr,fmt=*) 'Error in open_grads:'
     216             :       write(unit=fstderr,fmt=*)  & 
     217             :         "Attempt to append to existing files failed,"//  & 
     218             :         " because only one of the two GrADS files was found."
     219             :       error stop "open_grads"
     220             : 
     221             :     end if
     222             : 
     223             :     return
     224           0 :   end subroutine open_grads
     225             : 
     226             : !-------------------------------------------------------------------------------
     227             :   subroutine check_grads( iunit, fdir, fname,  & 
     228             :                           ia, iz, & 
     229             :                           day, month, year, time, dtwrite, & 
     230             :                           nvar,  & 
     231             :                           l_error, ntimes, nrecord, time_grads )
     232             : ! Description:
     233             : !   Given a GrADS file that already exists, this subroutine will attempt
     234             : !   to determine whether data can be safely appended to existing file.
     235             : ! References:
     236             : !   None
     237             : !-------------------------------------------------------------------------------
     238             :     use stat_file_module, only: & 
     239             :         grid_avg_variable ! Type
     240             : 
     241             :     use clubb_precision, only: & 
     242             :         time_precision ! Variable
     243             : 
     244             :     use constants_clubb, only:  & 
     245             :         fstderr,  & ! Variable 
     246             :         sec_per_hr, &
     247             :         sec_per_min
     248             : 
     249             :     implicit none
     250             : 
     251             :     ! Input Variables
     252             : 
     253             :     integer, intent(in) ::  & 
     254             :       iunit,              & ! Fortran file unit
     255             :       ia, iz,            & ! First and last level
     256             :       day, month, year,  & ! Day, month and year numbers
     257             :       nvar              ! Number of variables in the file
     258             : 
     259             :     character(len=*), intent(in) :: & 
     260             :       fdir, fname ! File directory and name
     261             : 
     262             :     real( kind = time_precision ), intent(in) :: & 
     263             :       time    ! Current model time        [s]
     264             : 
     265             :     real( kind = core_rknd ), intent(in) :: & 
     266             :       dtwrite ! Time interval between writes to the file    [s]
     267             : 
     268             :     ! Output Variables
     269             :     logical, intent(out) ::  & 
     270             :       l_error
     271             : 
     272             :     integer, intent(out) ::  & 
     273             :       ntimes, nrecord
     274             : 
     275             :     real(kind=time_precision), intent(out) :: time_grads
     276             : 
     277             :     ! Local Variables
     278             :     logical :: l_done
     279             :     integer :: ierr
     280             :     character(len = 256) :: line, tmp, date, dt
     281             : 
     282             :     integer ::  & 
     283             :       i, nx, ny, nzmax, & 
     284             :       ihour, imin, & 
     285             :       ia_in, iz_in, ntimes_in, nvar_in, & 
     286             :       day_in, month_in, year_in
     287             : 
     288             :     real( kind = core_rknd ) :: dtwrite_in
     289             : 
     290             :     real( kind = core_rknd ), dimension(:), allocatable :: z_in
     291             : 
     292             :     type (grid_avg_variable), dimension(:), allocatable :: var_in
     293             : 
     294             : !-------------------------------------------------------------------------------
     295             : 
     296             :     ! ---- Begin Code ----
     297             : 
     298             :     ! Initialize logical variables
     299             :     l_error = .false.
     300             :     l_done  = .false.
     301             : 
     302             :     ! Open control file
     303             :     open( unit = iunit, & 
     304             :           file = trim( fdir )//trim( fname )//'.ctl', & 
     305             :           status = 'old', iostat = ierr )
     306             :     if ( ierr < 0 ) l_done = .true.
     307             : 
     308             :     ! Read and process it
     309             : 
     310             :     read(unit=iunit,iostat=ierr,fmt='(a256)') line
     311             :     if ( ierr < 0 ) l_done = .true.
     312             : 
     313             :     do while ( .not. l_done )
     314             : 
     315             :       if ( index(line,'XDEF') > 0 ) then
     316             : 
     317             :         read(unit=line,fmt=*) tmp, nx
     318             :         if ( nx /= 1 ) then
     319             :           write(unit=fstderr,fmt=*) 'Error: XDEF can only be 1'
     320             :           l_error = .true.
     321             :         end if
     322             : 
     323             :       else if ( index(line,'YDEF') > 0 ) then
     324             : 
     325             :         read(unit=line,fmt=*) tmp, ny
     326             :         if ( ny /= 1 ) then
     327             :           write(unit=fstderr,fmt=*) "Error: YDEF can only be 1"
     328             :           l_error = .true.
     329             :         end if
     330             : 
     331             :       else if ( index(line,'ZDEF') > 0 ) then
     332             : 
     333             :         read(unit=line,fmt=*) tmp, iz_in
     334             : 
     335             :         if ( index(line,'LEVELS') > 0 ) then
     336             :           ia_in = 1
     337             :           allocate( z_in(ia_in:iz_in) )
     338             :           read(unit=iunit,fmt=*) (z_in(i),i=ia_in,iz_in)
     339             :         end if
     340             : 
     341             :       else if ( index(line,'TDEF') > 0 ) then
     342             : 
     343             :         read(unit=line,fmt=*) tmp, ntimes_in, tmp, date, dt
     344             :         read(unit=date(1:2),fmt=*) ihour
     345             :         read(unit=date(4:5),fmt=*) imin
     346             :         time_grads = real( ihour, kind=time_precision) * real(sec_per_hr,kind=time_precision) &
     347             :                    + real( imin, kind=time_precision ) * real(sec_per_min,kind=time_precision)
     348             :         read(unit=date(7:8),fmt=*) day_in
     349             :         read(unit=date(12:15),fmt=*) year_in
     350             : 
     351             :         select case( date(9:11) )
     352             :         case( 'JAN' )
     353             :           month_in = 1
     354             :         case( 'FEB' )
     355             :           month_in = 2
     356             :         case( 'MAR' )
     357             :           month_in = 3
     358             :         case( 'APR' )
     359             :           month_in = 4
     360             :         case( 'MAY' )
     361             :           month_in = 5
     362             :         case( 'JUN' )
     363             :           month_in = 6
     364             :         case( 'JUL' )
     365             :           month_in = 7
     366             :         case( 'AUG' )
     367             :           month_in = 8
     368             :         case( 'SEP' )
     369             :           month_in = 9
     370             :         case( 'OCT' )
     371             :           month_in = 10
     372             :         case( 'NOV' )
     373             :           month_in = 11
     374             :         case( 'DEC' )
     375             :           month_in = 12
     376             :         case default
     377             :           write(unit=fstderr,fmt=*) "Unknown month: "//date(9:11)
     378             :           l_error = .true.
     379             :         end select
     380             : 
     381             :         read(unit=dt(1:len_trim(dt)-2),fmt=*) dtwrite_in
     382             :         dtwrite_in = dtwrite_in * sec_per_min
     383             : 
     384             :       else if ( index(line,'ENDVARS') > 0 ) then
     385             : 
     386             :         l_done = .true.
     387             : 
     388             :       else if ( index(line,'VARS') > 0 ) then
     389             : 
     390             :         read(line,*) tmp, nvar_in
     391             :         allocate( var_in(nvar_in) )
     392             :         do i=1, nvar_in
     393             :           read(unit=iunit,iostat=ierr,fmt='(a256)') line
     394             :           read(unit=line,fmt=*) var_in(i)%name, nzmax
     395             :           if ( nzmax /= iz_in ) then
     396             :             write(unit=fstderr,fmt=*)  & 
     397             :               "Error reading ", trim( var_in(i)%name )
     398             :             l_error = .true.
     399             :           end if ! nzmax /= iz_in
     400             :         end do ! 1..nvar_in
     401             :       end if
     402             : 
     403             :       read(unit=iunit,iostat=ierr,fmt='(a256)') line
     404             :       if ( ierr < 0 ) l_done = .true.
     405             : 
     406             :     end do ! while ( .not. l_done )
     407             : 
     408             :     close( unit=iunit )
     409             : 
     410             :     ! Perform some error check
     411             : 
     412             :     if ( abs(ia_in - iz_in) /= abs(ia - iz) ) then
     413             :       write(unit=fstderr,fmt=*) "check_grads: size mismatch"
     414             :       l_error = .true.
     415             :     end if
     416             : 
     417             :     if ( day_in /= day ) then
     418             :       write(unit=fstderr,fmt=*) "check_grads: day mismatch"
     419             :       l_error = .true.
     420             :     end if
     421             : 
     422             :     if ( month_in /= month ) then
     423             :       write(unit=fstderr,fmt=*) "check_grads: month mismatch"
     424             :       l_error = .true.
     425             :     end if
     426             : 
     427             :     if ( year_in /= year ) then
     428             :       write(unit=fstderr,fmt=*) "check_grads: year mismatch"
     429             :       l_error = .true.
     430             :     end if
     431             : 
     432             :     if ( int( time_grads ) + ntimes_in*int( dtwrite_in )  & 
     433             :          /= int( time ) ) then
     434             :       write(unit=fstderr,fmt=*) "check_grads: time mismatch"
     435             :       l_error = .true.
     436             :     end if
     437             : 
     438             :     if ( int( dtwrite_in ) /= int( dtwrite) ) then
     439             :       write(unit=fstderr,fmt=*) 'check_grads: dtwrite mismatch'
     440             :       l_error = .true.
     441             :     end if
     442             : 
     443             :     if ( nvar_in /= nvar ) then
     444             :       write(unit=fstderr,fmt=*) 'check_grads: nvar mismatch'
     445             :       l_error = .true.
     446             :     end if
     447             : 
     448             :     if ( l_error ) then
     449             :       write(unit=fstderr,fmt=*) "check_grads diagnostic"
     450             :       write(unit=fstderr,fmt=*) "ia      = ", ia_in, ia
     451             :       write(unit=fstderr,fmt=*) "iz      = ", iz_in, iz
     452             :       write(unit=fstderr,fmt=*) "day     = ", day_in, day
     453             :       write(unit=fstderr,fmt=*) "month   = ", month_in, month
     454             :       write(unit=fstderr,fmt=*) "year    = ", year_in, year
     455             :       write(unit=fstderr,fmt=*) "time_grads / time    = ", time_grads, time
     456             :       write(unit=fstderr,fmt=*) "dtwrite = ", dtwrite_in, dtwrite
     457             :       write(unit=fstderr,fmt=*) "nvar    = ", nvar_in, nvar
     458             :     end if
     459             : 
     460             :     ! Set ntimes and nrecord to append to existing files
     461             : 
     462             :     ntimes  = ntimes_in
     463             :     nrecord = ntimes_in * nvar_in * iz_in + 1
     464             : 
     465             :     deallocate( z_in )
     466             : 
     467             :     ! The purpose of this statement is to avoid a compiler warning
     468             :     ! for tmp
     469             :     if (tmp =="") then
     470             :     end if
     471             :     ! Joshua Fasching June 2008
     472             : 
     473             :     return
     474             :   end subroutine check_grads
     475             : 
     476             : !-------------------------------------------------------------------------------
     477           0 :   subroutine write_grads( grads_file )
     478             : 
     479             : ! Description:
     480             : !   Write part of a GrADS file to data (.dat) file update control file (.ctl. 
     481             : !   Can be called as many times as necessary
     482             : ! References:
     483             : !   None
     484             : !-------------------------------------------------------------------------------
     485             : 
     486             :     use constants_clubb, only: & 
     487             :         fstderr ! Variable(s)
     488             : 
     489             :     use model_flags, only: &
     490             :         l_byteswap_io ! Variable
     491             : 
     492             :     use endian, only: & 
     493             :         big_endian, & ! Variable
     494             :         little_endian
     495             : 
     496             :     use stat_file_module, only: & 
     497             :         stat_file ! Type
     498             : 
     499             : !   use stat_file_module, only: &
     500             : !     clubb_i, clubb_j ! Variable(s)
     501             : 
     502             :     implicit none
     503             : 
     504             :     ! External
     505             :     intrinsic :: selected_real_kind
     506             : 
     507             :     ! Constant parameters
     508             :     integer, parameter :: &
     509             :       r4 = selected_real_kind( p=5 ) ! Specify 5 decimal digits of precision
     510             : 
     511             :     ! Input Variables
     512             :     type (stat_file), intent(inout) :: &
     513             :       grads_file ! Contains all information on the files to be written to
     514             : 
     515             :     ! Local Variables
     516             :     integer ::  & 
     517             :       ivar, & ! Loop indices
     518             :       ios     ! I/O status indicator
     519             : 
     520             :     character(len=15) :: date
     521             : 
     522             :     integer :: dtwrite_ctl ! Time increment for the ctl file
     523             :     character(len=2) :: dtwrite_units ! Units on dtwrite_ctl
     524             : 
     525             :     ! ---- Begin Code ----
     526             :     ! Check number of variables and write nothing if less than 1
     527             : 
     528           0 :     if ( grads_file%nvar < 1 ) return
     529             : 
     530             : #include "recl.inc"
     531             : 
     532             :     ! Output data to file
     533             :     open( unit=grads_file%iounit, & 
     534             :           file=trim( grads_file%fdir )//trim( grads_file%fname )//'.dat', & 
     535             :           form='unformatted', access='direct', & 
     536             :           recl=F_RECL*abs( grads_file%iz-grads_file%ia+1 )*grads_file%nlon*grads_file%nlat, & 
     537           0 :           status='unknown', iostat=ios )
     538           0 :     if ( ios /= 0 ) then
     539             :       write(unit=fstderr,fmt=*)  & 
     540           0 :         "write_grads: error opening binary file"
     541           0 :       write(unit=fstderr,fmt=*) "iostat = ", ios
     542           0 :       error stop
     543             :     end if
     544             : 
     545           0 :     if ( grads_file%ia <= grads_file%iz ) then
     546           0 :       do ivar=1,grads_file%nvar
     547             :         write(grads_file%iounit,rec=grads_file%nrecord)  &
     548           0 :           real( grads_file%grid_avg_var(ivar)%ptr(1:grads_file%nlon, &
     549           0 :                                          1:grads_file%nlat,grads_file%ia:grads_file%iz), kind=r4)
     550           0 :         grads_file%nrecord = grads_file%nrecord + 1
     551             :       end do
     552             : 
     553             :     else
     554           0 :       do ivar=1, grads_file%nvar
     555             :         write(grads_file%iounit,rec=grads_file%nrecord) & 
     556           0 :           real( grads_file%grid_avg_var(ivar)%ptr(1:grads_file%nlon, &
     557           0 :                                          1:grads_file%nlat,grads_file%ia:grads_file%iz:-1), kind=r4)
     558           0 :         grads_file%nrecord = grads_file%nrecord + 1
     559             :       end do
     560             : 
     561             :     end if ! grads_file%ia <= grads_file%iz
     562             : 
     563           0 :     close( unit=grads_file%iounit, iostat = ios )
     564             : 
     565           0 :     if ( ios /= 0 ) then
     566             :       write(unit=fstderr,fmt=*)  & 
     567           0 :         "write_grads: error closing binary file"
     568           0 :       write(unit=fstderr,fmt=*) "iostat = ", ios
     569           0 :       error stop
     570             :     end if
     571             : 
     572           0 :     grads_file%ntimes = grads_file%ntimes + 1
     573             : 
     574             :     ! Write control file
     575             : 
     576             :     open(unit=grads_file%iounit, & 
     577             :          file=trim( grads_file%fdir )//trim( grads_file%fname )//'.ctl', & 
     578           0 :          status='unknown', iostat=ios)
     579           0 :     if ( ios > 0 ) then
     580             :       write(unit=fstderr,fmt=*)  & 
     581           0 :         "write_grads: error opening control file"
     582           0 :       write(unit=fstderr,fmt=*) "iostat = ", ios
     583           0 :       error stop
     584             :     end if
     585             : 
     586             :     ! Write file header
     587             :     if ( ( big_endian .and. .not. l_byteswap_io ) &
     588             :       .or. ( little_endian .and. l_byteswap_io ) ) then
     589             :       write(unit=grads_file%iounit,fmt='(a)') 'OPTIONS BIG_ENDIAN'
     590             : 
     591             :     else
     592           0 :       write(unit=grads_file%iounit,fmt='(a)') 'OPTIONS LITTLE_ENDIAN'
     593             : 
     594             :     end if
     595             : 
     596           0 :     write(unit=grads_file%iounit,fmt='(a)') 'DSET ^'//trim( grads_file%fname )//'.dat'
     597           0 :     write(unit=grads_file%iounit,fmt='(a,e12.5)') 'UNDEF ',undef
     598             : 
     599           0 :     if ( grads_file%nlon == 1 ) then ! Use linear for a singleton X dimesion
     600           0 :       write(unit=grads_file%iounit,fmt='(a,f8.3,a)') 'XDEF    1 LINEAR ', grads_file%lon_vals, ' 1.'
     601             :     else
     602           0 :       write(unit=grads_file%iounit,fmt='(a,i5,a)') 'XDEF', grads_file%nlon,' LEVELS '
     603           0 :       write(unit=grads_file%iounit,fmt='(6f13.4)') grads_file%lon_vals
     604             :     end if
     605             : 
     606           0 :     if ( grads_file%nlat == 1 ) then ! Use linear for a singleton Y dimension
     607           0 :       write(unit=grads_file%iounit,fmt='(a,f8.3,a)') 'YDEF    1 LINEAR ', grads_file%lat_vals, ' 1.'
     608             :     else
     609           0 :       write(unit=grads_file%iounit,fmt='(a,i5,a)') 'YDEF', grads_file%nlat,' LEVELS '
     610           0 :       write(unit=grads_file%iounit,fmt='(6f13.4)') grads_file%lat_vals
     611             :     end if
     612             : 
     613           0 :     if ( grads_file%ia == grads_file%iz ) then ! If ia == iz, then Z is also singleton
     614           0 :       write(unit=grads_file%iounit,fmt='(a)') 'ZDEF    1 LEVELS 0.'
     615           0 :     else if ( grads_file%ia < grads_file%iz ) then
     616             :       write(unit=grads_file%iounit,fmt='(a,i5,a)')  & 
     617           0 :         'ZDEF', abs(grads_file%iz-grads_file%ia)+1,' LEVELS '
     618             :       write(unit=grads_file%iounit,fmt='(6f13.4)')  & 
     619           0 :         (grads_file%z(ivar-grads_file%ia+1),ivar=grads_file%ia,grads_file%iz)
     620             :     else
     621             :       write(unit=grads_file%iounit,fmt='(a,i5,a)')  & 
     622           0 :         'ZDEF',abs(grads_file%iz-grads_file%ia)+1,' LEVELS '
     623           0 :       write(grads_file%iounit,'(6f13.4)') (grads_file%z(grads_file%ia-ivar+1), &
     624           0 :         ivar=grads_file%ia,grads_file%iz,-1)
     625             :     end if
     626             : 
     627             :     call format_date( grads_file%day, grads_file%month, grads_file%year, grads_file%time, & ! In
     628           0 :                       date ) ! Out
     629             : 
     630             :     call determine_time_inc( grads_file%dtwrite, & ! In
     631           0 :                              dtwrite_ctl, dtwrite_units ) ! Out
     632             : 
     633           0 :     write(unit=grads_file%iounit,fmt='(a,i6,a,a,i5,a)') 'TDEF    ', & 
     634           0 :       grads_file%ntimes, ' LINEAR ', date, dtwrite_ctl, dtwrite_units
     635             : 
     636             :     ! Variables description
     637           0 :     write(unit=grads_file%iounit,fmt='(a,i5)') 'VARS', grads_file%nvar
     638             : 
     639           0 :     do ivar=1, grads_file%nvar, 1
     640           0 :       write(unit=grads_file%iounit,fmt='(a,i5,a,a)') & 
     641           0 :         grads_file%grid_avg_var(ivar)%name(1:len_trim(grads_file%grid_avg_var(ivar)%name)), &
     642           0 :         abs(grads_file%iz-grads_file%ia)+1,' 99 ', & 
     643             :         grads_file%grid_avg_var(ivar)%description( &
     644           0 :                                    1:len_trim(grads_file%grid_avg_var(ivar)%description))
     645             :     end do
     646             : 
     647           0 :     write(unit=grads_file%iounit,fmt='(a)') 'ENDVARS'
     648             : 
     649           0 :     close( unit=grads_file%iounit, iostat=ios )
     650           0 :     if ( ios > 0 ) then
     651             :       write(unit=fstderr,fmt=*)  & 
     652           0 :         "write_grads: error closing control file"
     653           0 :       write(unit=fstderr,fmt=*) "iostat = ",ios
     654           0 :       error stop
     655             :     end if
     656             : 
     657             :     return
     658             :   end subroutine write_grads
     659             : 
     660             : !---------------------------------------------------------
     661           0 :   subroutine format_date( day_in, month_in, year_in, time_in, &
     662           0 :                           date )
     663             : !
     664             : ! Description: 
     665             : !   This subroutine formats the current time of the model (given in seconds 
     666             : !   since the start time) to a date format usable as GrADS output.
     667             : ! References:
     668             : !   None
     669             : !---------------------------------------------------------
     670             :     use clubb_precision, only:  & 
     671             :         time_precision    ! Variable(s)
     672             : 
     673             :     use calendar, only:  & 
     674             :         compute_current_date ! Procedure(s)
     675             : 
     676             :     use calendar, only: & 
     677             :         month_names ! Variable(s)
     678             : 
     679             :     use constants_clubb, only: &
     680             :         sec_per_hr, & ! Variable(s)
     681             :         min_per_hr
     682             : 
     683             :     implicit none
     684             : 
     685             :     ! Input Variables
     686             :     integer, intent(in) :: & 
     687             :       day_in,   & ! Day of the Month at Model Start  [dd]
     688             :       month_in, & ! Month of the Year at Model Start [mm]
     689             :       year_in     ! Year at Model Start              [yyyy]
     690             : 
     691             :     real(kind=time_precision), intent(in) ::  & 
     692             :       time_in ! Time since Model Start              [s]
     693             : 
     694             :     ! Output Variables
     695             :     character(len=15), intent(out) ::  & 
     696             :       date ! Current Date in format 'hh:mmZddmmmyyyy'
     697             : 
     698             :     ! Local Variables
     699             :     integer :: iday, imonth, iyear  ! Day, month, year
     700             :     real(kind=time_precision) :: time ! time      [s]
     701             : 
     702             :     ! ---- Begin Code ----
     703             : 
     704             :     ! Copy input arguments into local variables
     705             : 
     706           0 :     iday   = day_in
     707           0 :     imonth = month_in
     708           0 :     iyear  = year_in
     709           0 :     time   = time_in
     710             : 
     711             :     call compute_current_date( day_in, month_in, &  ! In
     712             :                                year_in, & ! In
     713             :                                time_in, & ! In 
     714             :                                iday, imonth, & ! Out
     715             :                                iyear, & ! Out
     716           0 :                                time ) ! Out
     717             : 
     718           0 :     date = 'hh:mmZddmmmyyyy'
     719           0 :     write(unit=date(7:8),fmt='(i2.2)') iday
     720           0 :     write(unit=date(9:11),fmt='(a3)') month_names(imonth)
     721           0 :     write(unit=date(12:15),fmt='(i4.4)') iyear
     722           0 :     write(unit=date(1:2),fmt='(i2.2)') floor(time/real(sec_per_hr,kind=time_precision ))
     723             :     write(unit=date(4:5),fmt='(i2.2)')  & 
     724           0 :       int( mod( nint( time ), nint(sec_per_hr) ) / nint(min_per_hr) )
     725             : 
     726           0 :     return
     727             :   end subroutine format_date
     728             : 
     729             : !-------------------------------------------------------------------------------
     730           0 :   subroutine determine_time_inc( dtwrite_sec, &
     731           0 :                                  dtwrite_ctl, units )
     732             : ! Description:
     733             : !   Determine the units on the time increment, since GrADS only allows a 2 digit
     734             : !   time increment.
     735             : ! References:
     736             : !   None
     737             : !-------------------------------------------------------------------------------
     738             :     use constants_clubb, only: &
     739             :         sec_per_day, & ! Constants
     740             :         sec_per_hr, &
     741             :         sec_per_min
     742             : 
     743             : 
     744             :     implicit none
     745             : 
     746             :     ! External
     747             :     intrinsic :: max, floor
     748             : 
     749             :     ! Input Variables
     750             :     real(kind=core_rknd), intent(in) :: &
     751             :       dtwrite_sec ! Time increment in GrADS [s]
     752             : 
     753             :     ! Output Variables
     754             :     integer, intent(out) :: &
     755             :       dtwrite_ctl ! Time increment in GrADS [units vary]
     756             : 
     757             :     character(len=2), intent(out) :: units ! Units on dtwrite_ctl
     758             : 
     759             :     ! Local variables
     760             :     real(kind=core_rknd) :: &
     761             :       dtwrite_min, & ! Time increment [minutes]
     762             :       dtwrite_hrs, & ! Time increment [hours]
     763             :       dtwrite_days   ! Time increment [days]
     764             : 
     765             :     ! ---- Begin Code ----
     766             : 
     767             :     ! Since GrADs can't handle a time increment of less than a minute we assume
     768             :     ! 1 minute output for an output frequency of less than a minute.
     769           0 :     dtwrite_min = real( floor( dtwrite_sec/sec_per_min ), kind=core_rknd )
     770           0 :     dtwrite_min = max( 1._core_rknd, dtwrite_min )
     771             : 
     772           0 :     if ( dtwrite_min <= 99._core_rknd ) then
     773           0 :       dtwrite_ctl = int( dtwrite_min )
     774           0 :       units = 'mn'
     775             :     else
     776           0 :       dtwrite_hrs = dtwrite_sec / sec_per_hr
     777           0 :       if ( dtwrite_hrs <= 99._core_rknd ) then
     778           0 :         dtwrite_ctl = int( dtwrite_hrs )
     779           0 :         units = 'hr'
     780             :       else
     781           0 :         dtwrite_days = dtwrite_sec / sec_per_day
     782           0 :         if ( dtwrite_days <= 99._core_rknd ) then
     783           0 :           dtwrite_ctl = int( dtwrite_days )
     784           0 :           units = 'dy'
     785             :         else
     786           0 :           error stop "Fatal error in determine_time_inc"
     787             :         end if ! dwrite_days <= 99.
     788             :       end if ! dtwrite_hrs <= 99.
     789             :     end if ! dtwrite_min <= 99.
     790             : 
     791           0 :     return
     792             :   end subroutine determine_time_inc
     793             : 
     794             : end module output_grads
     795             : !-------------------------------------------------------------------------------

Generated by: LCOV version 1.14