init_mod.F90

Go to the documentation of this file.

 
module init_mod
 
  implicit none
 
  public
 
  integer, parameter :: maxvars = 60
  character(len=10)  :: maskvar = 'h'
  type :: vardefs
     character(len= 20)   :: var_name
     character(len=120)   :: long_name
     character(len= 20)   :: units
     character(len= 20)   :: var_remapmethod
     integer              :: var_dimen
     character(len=  4)   :: var_grid
     character(len= 20)   :: var_pair
     character(len=  4)   :: var_pair_grid
  end type vardefs
 
  type(vardefs) :: outvars(maxvars)
 
  character(len=10)  :: ftype
  character(len=10)  :: fsrc
  character(len=10)  :: fdst
  character(len=120) :: wgtsdir
  character(len=120) :: griddir
  character(len=20)  :: input_file
 
  integer :: nxt
  integer :: nyt
  integer :: nlevs
 
  integer :: nxr
  integer :: nyr
 
  integer :: logunit
  logical :: debug
  logical :: do_ocnprep
 
contains
  subroutine readnml(fname,errmsg,rc)
 
    character(len=*), intent(in)  :: fname
    character(len=*), intent(out) :: errmsg
    integer,          intent(out) :: rc
 
    ! local variable
    logical :: fexist
    integer :: ierr, iounit
    integer :: srcdims(2), dstdims(2)
    !----------------------------------------------------------------------------
 
    namelist /ocniceprep_nml/ ftype, wgtsdir, griddir, srcdims, dstdims, debug
 
    srcdims = 0; dstdims = 0
    errmsg='' ! for successful return
    rc = 0    ! for successful retun
 
    inquire(file=trim(fname), exist=fexist)
    if (.not. fexist) then
       write (errmsg, '(a)') 'FATAL ERROR: input file '//trim(fname)//' does not exist.'
       rc = 1
       return
    else
       ! Open and read namelist file.
       open (action='read', file=trim(fname), iostat=ierr, newunit=iounit)
       read (nml=ocniceprep_nml, iostat=ierr, unit=iounit)
       if (ierr /= 0) then
          rc = 1
          write (errmsg, '(a)') 'FATAL ERROR: invalid namelist format.'
          return
       end if
       close (iounit)
    end if
 
    ! append slash to wgtsdir and griddir
    wgtsdir = trim(wgtsdir)//'/'
    griddir = trim(griddir)//'/'
 
    ! check that model is either ocean or ice
    if (trim(ftype) /= 'ocean' .and. trim(ftype) /= 'ice') then
       rc = 1
       write (errmsg, '(a)') 'FATAL ERROR: ftype must be ocean or ice'
       return
    end if
 
    ! set grid dimensions and names
    nxt = srcdims(1); nyt = srcdims(2)
    nxr = dstdims(1); nyr = dstdims(2)
    fsrc = '' ; fdst = ''
    if (nxt == 1440 .and. nyt == 1080) fsrc = 'mx025'    ! 1/4deg tripole
    if (nxt ==  720 .and. nyt ==  576) fsrc = 'mx050'    ! 1/2deg tripole
    if (nxt ==  360 .and. nyt ==  320) fsrc = 'mx100'    ! 1deg tripole
    if (len_trim(fsrc) == 0) then
       rc = 1
       write(errmsg,'(a)')'FATAL ERROR: source grid dimensions invalid'
       return
    end if
 
    if (nxr == 1440 .and. nyr == 1080) fdst = 'mx025'    ! 1/4deg tripole
    if (nxr ==  720 .and. nyr ==  576) fdst = 'mx050'    ! 1/2deg tripole
    if (nxr ==  360 .and. nyr ==  320) fdst = 'mx100'    ! 1deg tripole
    if (nxr ==   72 .and. nyr ==   35) fdst = 'mx500'    ! 5deg tripole
    if (len_trim(fdst) == 0) then
       rc = 1
       write(errmsg,'(a)')'FATAL ERROR: destination grid dimensions invalid'
       return
    end if
 
    if (trim(fsrc) .eq. trim(fdst)) then
       rc = 1
       write(errmsg,'(a)')'FATAL ERROR: Source and destination grids must differ'
       return
    end if
 
    if (trim(fdst) == 'mx500') then
       rc = 1
       write(errmsg,'(a)')'FATAL ERROR: 5deg destination grid is not supported'
       return
    end if
 
    ! initialize the source file types
    if (trim(ftype) == 'ocean') then
       do_ocnprep = .true.
    else
       do_ocnprep = .false.
    end if
 
    input_file = trim(ftype)//'.nc'
    inquire (file=trim(input_file), exist=fexist)
    if (.not. fexist) then
       write (errmsg, '(a)') 'FATAL ERROR: input file '//trim(input_file)//' does not exist.'
       rc=1
       return
    end if
 
    ! log file
    open(newunit=logunit, file=trim(ftype)//'.prep.log',form='formatted')
    if (debug) write(logunit, '(a)')'input file: '//trim(input_file)
 
    ! all checks pass, continue
    write(errmsg,'(a)') 'Namelist successfully read, continue'
    rc = 0
 
  end subroutine readnml
 
  subroutine readcsv(fname,errmsg,rc,nvalid)
 
    character(len=*), intent(in)  :: fname
    character(len=*), intent(out) :: errmsg
    integer, intent(out)          :: rc
    integer, intent(out)          :: nvalid
 
    ! local variables
    character(len=100) :: chead
    character(len= 20) :: c1,c3,c4,c5,c6
    integer :: i2, idx1,idx2
    integer :: nn,n,ierr,iounit
    !----------------------------------------------------------------------------
 
    errmsg='' ! for successful return
    rc = 0    ! for successful retun
 
    open(newunit=iounit, file=trim(fname), status='old', iostat=ierr)
    if (ierr /= 0) then
       rc = 1
       write (errmsg, '(a)') 'FATAL ERROR: input file '//trim(fname)//' does not exist.'
       return
    end if
 
    read(iounit,*)chead
    nn=0
    do n = 1,maxvars
       read(iounit,*,iostat=ierr)c1,i2,c3,c4,c5,c6
       if (ierr .ne. 0) exit
       if (len_trim(c1) > 0) then
          nn = nn+1
          outvars(nn)%var_name = trim(c1)
          outvars(nn)%var_dimen = i2
          outvars(nn)%var_grid = trim(c3)
          outvars(nn)%var_remapmethod = trim(c4)
          outvars(nn)%var_pair = trim(c5)
          outvars(nn)%var_pair_grid = trim(c6)
       end if
    end do
    close(iounit)
    nvalid = nn
    ! check for u,v pairs, these should be listed in csv file in ordered pairs
    idx1 = 0; idx2 = 0
    do n = 1,nvalid
       if (len_trim(outvars(n)%var_pair) > 0 .and. idx1 .eq. 0) then
          idx1 = n
          idx2 = n+1
       end if
    end do
 
    if (idx1*idx2 > 0) then
       if (trim(outvars(idx1)%var_pair) /= trim(outvars(idx2)%var_name)) then
          rc = 1
          write(errmsg,'(a)')'FATAL ERROR: vector pair for '//trim(outvars(idx1)%var_name) &
               //' is not set correctly'
          return
       end if
       if (trim(outvars(idx2)%var_pair) /= trim(outvars(idx1)%var_name)) then
          rc = 1
          write(errmsg,'(a)')'FATAL ERROR: vector pair for '//trim(outvars(idx2)%var_name) &
               //' is not set correctly'
          return
       end if
 
       ! check for u velocities on u-staggers and v-velocities on v-staggers
       if (outvars(idx1)%var_name(1:1) == 'u') then
          if ((outvars(idx1)%var_grid(1:2) /= 'Cu') .and. outvars(idx1)%var_grid(1:2) /= 'Bu') then
             rc = 1
             write(errmsg,'(a)')'FATAL ERROR: u-vector has wrong grid '
             return
          end if
       end if
       if (outvars(idx2)%var_name(1:1) == 'v') then
          if ((outvars(idx2)%var_grid(1:2) /= 'Cv') .and. outvars(idx2)%var_grid(1:2) /= 'Bu') then
             rc = 1
             write(errmsg,'(a)')'FATAL ERROR: v-vector has wrong grid '
             return
          end if
       end if
    end if
 
    ! all checks pass, continue
    write(errmsg,'(a)')'CSV successfully read, continue'
    rc = 0
 
  end subroutine readcsv
end module init_mod