mod_nesting.f90

Go to the documentation of this file.

!/===========================================================================/
! Copyright (c) 2007, The University of Massachusetts Dartmouth 
! Produced at the School of Marine Science & Technology 
! Marine Ecosystem Dynamics Modeling group
! All rights reserved.
!
! FVCOM has been developed by the joint UMASSD-WHOI research team. For 
! details of authorship and attribution of credit please see the FVCOM
! technical manual or contact the MEDM group.
!
! 
! This file is part of FVCOM. For details, see http://fvcom.smast.umassd.edu 
! The full copyright notice is contained in the file COPYRIGHT located in the 
! root directory of the FVCOM code. This original header must be maintained
! in all distributed versions.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 
! AND ANY EXPRESS OR  IMPLIED WARRANTIES, INCLUDING,  BUT NOT  LIMITED TO,
! THE IMPLIED WARRANTIES OF MERCHANTABILITY AND  FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED.  
!
!/---------------------------------------------------------------------------/
! CVS VERSION INFORMATION
! $Id$
! $Name$
! $Revision$
!/===========================================================================/

Module mod_nesting
  use all_vars
  use mod_utils
  use mod_ncdio
  use mod_par
  use sinter
  implicit none

  SAVE

  ! For data IO
  TYPE nest_data
     INTEGER :: idx =0
     INTEGER :: rng(2) =0
     INTEGER :: nblk=0

     REAL(sp), POINTER :: ua_blk(:,:),va_blk(:,:),el_blk(:,:)
     REAL(sp), POINTER :: u_blk(:,:,:),v_blk(:,:,:)
     REAL(sp), POINTER :: s1_blk(:,:,:),t1_blk(:,:,:)
     REAL(sp), POINTER :: hyw_blk(:,:,:)
     TYPE(time), POINTER :: time_blk(:)

     REAL(sp), POINTER :: wcell_blk(:,:),wnode_blk(:,:)

  END TYPE nest_data



  ! GRID AND DATA FOR RUNNING AS SUBDOMAIN
  TYPE(grid), POINTER :: nesting_grid
  TYPE(nest_data), POINTER :: nesting_data
  TYPE(ncfile), POINTER :: nesting_file


  !========================================================
  ! Used in NESTING CODE
  ! This memory holds the data for each variable at the current time.
  ! This is where the data that is updated is stored in arrays which
  ! are the size of the nesting boundary, and indexed to the FVCOM domain. 
  REAL(sp), ALLOCATABLE :: ua_nest(:),va_nest(:),el_nest(:)
  REAL(sp), ALLOCATABLE :: u_nest(:,:),v_nest(:,:)
  REAL(sp), ALLOCATABLE :: s1_nest(:,:),t1_nest(:,:)
  REAL(sp), ALLOCATABLE :: hyw_nest(:,:)

  REAL(sp), ALLOCATABLE :: u_nest_l(:,:),v_nest_l(:,:)
  REAL(sp), ALLOCATABLE :: s1_nest_l(:,:),t1_nest_l(:,:)
  REAL(sp), ALLOCATABLE :: hyw_nest_l(:,:)
  
  REAL(sp), ALLOCATABLE, TARGET :: zz_l(:,:),zz1_l(:,:),h_l(:),h1_l(:)

  REAL(sp), ALLOCATABLE :: wcell_nest(:),wnode_nest(:)

  ! 
  TYPE(ncvar), POINTER :: var_ua
  TYPE(ncvar), POINTER :: var_va
  TYPE(ncvar), POINTER :: var_el
  TYPE(ncvar), POINTER :: var_u
  TYPE(ncvar), POINTER :: var_v
  TYPE(ncvar), POINTER :: var_s1
  TYPE(ncvar), POINTER :: var_t1
  TYPE(ncvar), POINTER :: var_hyw
  TYPE(ncvar), POINTER :: var_time1
  TYPE(ncvar), POINTER :: var_time2

  TYPE(ncvar), POINTER :: var_wcell
  TYPE(ncvar), POINTER :: var_wnode

  !========================================================


  ! GRID AND DATA FOR OUTPUT
  INTEGER :: ncnest_num
  CHARACTER(LEN=80), ALLOCATABLE :: ncnest_fnames(:)
  TYPE(grid), POINTER :: ncnest_grids(:)
  TYPE(nest_data), POINTER :: ncnest_data(:)

  
  LOGICAL, PRIVATE :: need_init_nest = .true.

  TYPE(time) :: interval_time_ncnest, time_interval

  !--Parameters in NameList NML_NESTING
  !TYPE OF NESTING:
  !  1:  DIRECT NESTING     -- The input is the direct NCNEST output of 
  !                            large domain FVCOM model
  !  2:  INDIRECT NESTING   -- Same as 1, but the input file is the subtidal
  !                            values from the NCNEST output of large domain
  !                            FVCOM model plus the Forman tidal analysis 
  !                            elevations and velocities
  !  3:  RELAXATION NESTING -- The nesting with a relaxation method (an example
  !                            is to get nesting data from HYCOM)
  LOGICAL nesting_on                   !!TRUE IF OUTPUT RESART FILES
  CHARACTER(LEN=80) nesting_type       !!TYPE OF NESTING: 1, 2, 3
  INTEGER :: nesting_blocksize         !!SIZE OF DATA BLOCKS IN FILE
  CHARACTER(LEN=80) nesting_file_name  !!NAME OF RESTART FILE

  namelist /nml_nesting/     &
       & nesting_on,         &
       & nesting_type,       &
       & nesting_blocksize,  &
       & nesting_file_name


  !--Parameters in NameList NML_NCNEST
  LOGICAL ncnest_on
  INTEGER :: ncnest_blocksize
  CHARACTER(LEN=160) ncnest_node_files
  CHARACTER(LEN=80) ncnest_out_interval

  namelist /nml_ncnest/     &
       & ncnest_on,         &
       & ncnest_blocksize,  &
       & ncnest_node_files, &
       & ncnest_out_interval
  

  INTEGER :: kb_l
  INTEGER :: kbm1_l

CONTAINS
  !==============================================================================!
  !
  !==============================================================================!
  SUBROUTINE name_list_initialize_nest
    USE control

    IMPLICIT NONE

    !--Parameters in NameList NML_NESTING
    nesting_on = .false.
    nesting_type = "'1' or '2' or '3'"
    nesting_blocksize = -1
    nesting_file_name = trim(casename)//"_nesting.nc"

    !--Parameters in NameList NML_NCNEST
    ncnest_on = .false.
    ncnest_blocksize = -1
    ncnest_node_files = "none"
    ncnest_out_interval = "A length of time: 'seconds= ','days= ', or 'cycles= '"


    kb_l   = 0
    kbm1_l = 0

    RETURN
  END SUBROUTINE name_list_initialize_nest
  !==============================================================================!
  !  
  !==============================================================================!  
  SUBROUTINE name_list_print_nest
    USE control

    IMPLICIT NONE

    WRITE(unit=ipt,nml=nml_ncnest)

    WRITE(unit=ipt,nml=nml_nesting)


    RETURN
  END SUBROUTINE name_list_print_nest
  !==============================================================================!
  !
  !==============================================================================!
  SUBROUTINE name_list_read_nest
    USE mod_utils
    USE control
    USE mod_set_time, ONLY : get_output_file_interval

    IMPLICIT NONE

    INTEGER :: ios,I
    CHARACTER(LEN=120) :: FNAME

    IF(dbg_set(dbg_sbr)) write(ipt,*) "Subroutine Begins: name_list_read_nest;"

    ios = 0
    fname = "./"//trim(casename)//"_run.nml"
    IF(dbg_set(dbg_io)) write(ipt,*) "Get_nestpar: File: ",trim(fname)

    CALL fopen(nmlunit,trim(fname),'cfr')

    !READ NAME LIST FILE

    !READ NESTING FLAG
    READ(unit=nmlunit, nml=nml_nesting,iostat=ios)  
    IF(ios /= 0)THEN
       IF(dbg_set(dbg_log)) write(unit=ipt,nml=nml_nesting)
       CALL fatal_error("Can Not Read NameList NML_NESTING from file: "//trim(fname))
    END IF

    if(dbg_set(dbg_scl)) &
         & write(ipt,*) "Read_Name_List:NML_NESTING"

    if(dbg_set(dbg_scl)) &
         & write(unit=ipt,nml=nml_nesting)

    rewind(nmlunit)

    !READ NESTING FLAG
    READ(unit=nmlunit, nml=nml_ncnest,iostat=ios)  
    IF(ios /= 0)THEN
       IF(dbg_set(dbg_log)) write(unit=ipt,nml=nml_ncnest)
       CALL fatal_error("Can Not Read NameList NML_NCNEST from file: "//trim(fname))
    END IF

    if(dbg_set(dbg_scl)) &
         & write(ipt,*) "Read_Name_List: NML_NCNEST"

    if(dbg_set(dbg_scl)) &
         & write(unit=ipt,nml=nml_ncnest)



    CLOSE(nmlunit)

    ! DO SOME BASIC CHECKING ON THE NESTING NAMELIST
    IF(nesting_on) THEN

       IF( nesting_blocksize < 2) CALL fatal_error &
            & ("THE NESTING_BLOCKSIZE IS LESS THAN TWO IN THE NESTING NAME LIST")

       IF(len_trim(nesting_file_name) == 0 ) CALL fatal_error &
            & ("THE NESTING FILE NAME IS EMPTY IN THE NAME LIST")

    END IF

    IF(ncnest_on) THEN

       IF( ncnest_blocksize < 2) CALL fatal_error &
            & ("THE NCNEST_BLOCKSIZE IS LESS THAN TWO IN THE NCNEST NAME LIST")

       IF(ncnest_node_files == 'none' .or. len_trim(ncnest_node_files)==0)CALL fatal_error &
            & ("THE NCNEST_NODE_FILES VARIABLE IS EMPTY IN THE NCNEST NAME LIST")

       CALL get_output_file_interval(trim(ncnest_out_interval),interval_time_ncnest)

    END IF

    CLOSE(nmlunit)

    if(dbg_set(dbg_sbr)) &
         & write(ipt,*) "Subroutine Ends: name_list_read_nest;"    

  END SUBROUTINE name_list_read_nest

  SUBROUTINE open_nesting_file
    IMPLICIT NONE
    TYPE(ncfile), POINTER :: NCF
    integer :: charnum
    logical :: back=.true.
    character(len=160) :: pathnfile
        ! LOAD NESTING NETCDF FILE
    IF (nesting_on) THEN

       ! TEST FILE NAME
       charnum = index(nesting_file_name,".nc",back)
       if (charnum /= len_trim(nesting_file_name)-2)&
            & CALL warning("Nesting File does not end in .nc", &
            & trim(nesting_file_name))
       
       ! INITIALIZE TYPE TO HOLD FILE METADATA
       pathnfile= trim(input_dir)//trim(nesting_file_name)
       CALL  nc_init(ncf,pathnfile)
       
       ! OPEN THE FILE AND LOAD METADATA
       if(.not. ncf%OPEN) then
          Call nc_open(ncf)
          CALL nc_load(ncf)
          filehead => add(filehead,ncf)
       end if
       
    END IF

  END SUBROUTINE open_nesting_file



  ! DEFINE SOME DUMMY ROUTINES

  SUBROUTINE set_var(NOW,UA,VA,EL,U,V,S1,T1,HYW)
    IMPLICIT NONE
    TYPE(time), INTENT(IN) :: NOW    
    REAL(SP), ALLOCATABLE, OPTIONAL :: UA(:),VA(:),EL(:)
    REAL(SP), ALLOCATABLE, OPTIONAL :: U(:,:),V(:,:),S1(:,:),T1(:,:),HYW(:,:)
  END SUBROUTINE set_var

  SUBROUTINE set_var_wave(NOW,HSC1,TPEAK,DIRDEG1)
    IMPLICIT NONE
    TYPE(time), INTENT(IN) :: NOW    
    REAL(SP), ALLOCATABLE, OPTIONAL :: HSC1(:),TPEAK(:),DIRDEG1(:)   
  END SUBROUTINE set_var_wave
  
  SUBROUTINE archive_nest
    IMPLICIT NONE
  END SUBROUTINE archive_nest

  SUBROUTINE archive_nest_wave
    IMPLICIT NONE
  END SUBROUTINE archive_nest_wave


!====================================================================
  SUBROUTINE update_itime_nest(VAR1,VAR2,NOW)
    IMPLICIT NONE
    TYPE(ncvar),  POINTER :: VAR1
    TYPE(ncvar),  POINTER :: VAR2
    TYPE(ncatt), POINTER :: ATT
    TYPE(time), INTENT(in) :: NOW
    INTEGER, POINTER :: D1,D2
    LOGICAL :: TEST2
    INTEGER :: TEST
    CHARACTER(len=80):: TZONE

    test2 = is_valid_itime(var1,var2,tzone)
    IF(.not. test2) THEN
       CALL print_var(var1)
       CALL print_var(var2)
       CALL fatal_error &
            ("CAN NOT UPDATE TIME FOR INVALID INTEGER TIME VARIABLES")
    END IF

    CALL nc_point_var(var1,d1)

    CALL nc_point_var(var2,d2)

    test = time2ncitime_nest(now,d1,d2)

!    if(.not. TEST) call fatal_error("That is bad times man!") 
    if(test==0) call fatal_error("That is bad times man!")
    ! THIS SHOULD NEVER HAPPEN?
    
  END SUBROUTINE update_itime_nest
!====================================================================
!======================================================
   FUNCTION time2ncitime_nest(MJD,D,MS) RESULT(res)
     implicit none
     INTEGER :: res
     TYPE(time), INTENT(IN) :: mjd
     INTEGER, INTENT(OUT) :: d, ms
     REAL(dp) :: msec

     res = -1
     msec = dble(mjd%MuSod) / 1000.0_dp
     ms = anint(msec)

     ! CHECK TO MAKE SURE IT IS NOT TOO LARGE
     IF (abs(mjd%MJD) .GT. huge(d)) THEN
        res =0 
        return
     END IF
     
     d = mjd%MJD

   END FUNCTION time2ncitime_nest
!======================================================
!====================================================================
  SUBROUTINE update_float_time_nest(VAR,NOW)
    IMPLICIT NONE
    TYPE(ncvar),  POINTER :: VAR
    TYPE(time), INTENT(in) :: NOW
    REAL(SP), POINTER :: Data
    LOGICAL :: TEST
    CHARACTER(len=80):: TZONE

    test = is_valid_float_days(var,tzone)
    IF(.not. test) THEN
       CALL print_var(var)
       call print_att_list(var)
       CALL fatal_error &
            ("CAN NOT UPDATE TIME FOR INVALID FLOATING POINT TIME VARIABLE")
    END IF

    CALL nc_point_var(var,data)
    
    Data = days(now)

  END SUBROUTINE update_float_time_nest
!====================================================================
!====================================================================
 FUNCTION float_time_object_nest(use_mjd,DIM,size) RESULT(VAR)
    IMPLICIT NONE
    TYPE(ncvar),  POINTER :: var
    logical, intent(in) :: use_mjd
    TYPE(ncdim),  POINTER, OPTIONAL :: dim
    INTEGER, OPTIONAL :: size
    TYPE(ncatt), POINTER :: att
    REAL(sp),pointer :: data_vec(:)
    REAL(sp),pointer :: data_scl

    IF(PRESENT(size)) THEN
       ALLOCATE(data_vec(size))
    ELSE
       ALLOCATE(data_vec(1))
       data_scl =>data_vec(1)
    END IF

    IF (PRESENT(dim)) THEN
       var  => nc_make_pvar(name='time', values=data_vec, dim1= dim)
       if(associated(var%vec_flt))then
         var%scl_flt => var%vec_flt(1)
       else
         var%scl_dbl => var%vec_dbl(1)
       endif
    ELSE
       var  => nc_make_pvar(name='time', values=data_scl)
    END IF
    
    att  => nc_make_att(name='long_name',values='time')
    var  => add(var,att)
    
    IF (use_mjd) THEN
       att  => nc_make_att(name='units',values=mjd_units)
       var  => add(var,att)
       
       att  => nc_make_att(name='format',values=fmat)
       var  => add(var,att)

       att  => nc_make_att(name='time_zone',values='UTC') 
       var  => add(var,att)
       
    ELSE
       att  => nc_make_att(name='units',values=days_units)
       var  => add(var,att)       
       
       att  => nc_make_att(name='time_zone',values='none') 
       var  => add(var,att)
    END IF
    

  END FUNCTION float_time_object_nest
!====================================================================
!====================================================================
 FUNCTION itime_object_nest(use_mjd,DIM,size) RESULT(VAR)
    IMPLICIT NONE
    TYPE(ncvar),  POINTER :: var
    logical, intent(in) :: use_mjd
    TYPE(ncdim),  POINTER, OPTIONAL :: dim
    INTEGER, OPTIONAL :: size
    TYPE(ncatt), POINTER :: att
    INTEGER,POINTER :: data_vec(:)
    INTEGER,POINTER :: data_scl

    IF(PRESENT(size)) THEN
       ALLOCATE(data_vec(size))
    ELSE
       ALLOCATE(data_vec(1))
       data_scl =>data_vec(1)
    END IF
    
        ! Itime
    IF (PRESENT(dim)) THEN
        var  => nc_make_pvar(name='Itime', values=data_vec, dim1= dim)
        var%SCL_INT => var%VEC_INT(1)
    ELSE
       var  => nc_make_pvar(name='Itime', values=data_scl)
    END IF

    IF (use_mjd) THEN
       att  => nc_make_att(name='units',values=mjd_units)
       var  => add(var,att)

       att  => nc_make_att(name='format',values=fmat)
       var  => add(var,att)

       att  => nc_make_att(name='time_zone',values='UTC') 
       var  => add(var,att)
    ELSE
       att  => nc_make_att(name='units',values=days_units)
       var  => add(var,att)
              
       att  => nc_make_att(name='time_zone',values='none') 
       var  => add(var,att)
    END IF

  END FUNCTION itime_object_nest
!====================================================================

END Module mod_nesting